junco coverage - 83.83%

Files
Source

postfun_cog <- function(ret, spl, fulldf, .spl_context,
                        var_names = c("AVAL", "CHG", "BASE"),
                        stats = list(
                          main = c(N = "N", mean = "Mean", SD = "SD", SE = "SE", Med = "Med", Min = "Min", Max = "Max"),
                          base = c(mean = "Mean")
                        )) {
  all_expr <- expression(TRUE)
  colset <- .spl_context[nrow(.spl_context), "value"][[1]]

  # Check if colset is one of the main variables (default: AVAL or CHG)
  if (colset == var_names[1] || colset == var_names[2]) {
    # Create vectors for make_split_result
    values <- stats$main
    labels <- stats$main

    # Create datasplit and subset_exprs lists with the same length as values
    datasplit <- replicate(length(values), fulldf, simplify = FALSE)
    names(datasplit) <- names(values)

    subset_exprs <- replicate(length(values), all_expr, simplify = FALSE)

    ret <- rtables::make_split_result(
      values = values,
      labels = labels,
      datasplit = datasplit,
      subset_exprs = subset_exprs
    )
  } else if (colset == var_names[3]) { # Default: BASE
    # For base variable, use base stats
    values <- stats$base
    labels <- stats$base
    if (names(values)[1] == "mean") {
      # Keep backward compatibility by adding "Base " prefix to the first label if it's "mean"
      labels[1] <- paste("Base", labels[1])
    }

    # Create datasplit and subset_exprs lists with the same length as values
    datasplit <- replicate(length(values), fulldf, simplify = FALSE)
    names(datasplit) <- names(values)

    subset_exprs <- replicate(length(values), all_expr, simplify = FALSE)

    ret <- rtables::make_split_result(
      values = values,
      labels = labels,
      datasplit = datasplit,
      subset_exprs = subset_exprs
    )
  } else {
    stop("something bad happened :(")
  }
  ret
}

postfun_eq5d <- function(ret, spl, fulldf, .spl_context) {
  all_expr <- expression(TRUE)
  colset <- .spl_context[nrow(.spl_context), "value"][[1]]
  if (colset == "AVAL") {
    ret <- make_split_result(
      values = c(N = "N", mean = "Mean", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
      labels = c(N = "N", mean = "Mean", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
      datasplit = list(N = fulldf, mean = fulldf, SD = fulldf, Med = fulldf, Min = fulldf, Max = fulldf),
      subset_exprs = list(all_expr, all_expr, all_expr, all_expr, all_expr, all_expr)
    )
  } else if (colset == "BASE") {
    ret <- make_split_result(
      values = c(mean_sd = "mean_sd"),
      labels = c(mean_sd = "Base Mean (SD)"),
      datasplit = list(mean_sd = fulldf),
      subset_exprs = list(all_expr)
    )
  } else if (colset == "CHG") {
    ret <- make_split_result(
      values = c(N = "N", mean = "Mean", SE = "SE", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
      labels = c(N = "N", mean = "Mean", SE = "SE", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
      datasplit = list(N = fulldf, mean = fulldf, SE = fulldf, SD = fulldf, Med = fulldf, Min = fulldf, Max = fulldf),
      subset_exprs = list(all_expr, all_expr, all_expr, all_expr, all_expr, all_expr, all_expr)
    )
  } else {
    stop("something bad happened :(")
  }
  ret
}

calc_one_visit <- function(datvec, decimal, statnm, visit, varnm, roundmethod = c("sas", "iec"), exclude_visits,
                           var_names = c("AVAL", "CHG", "BASE")) {
  roundmethod <- match.arg(roundmethod)
  if (is.na(decimal)) {
    decimal <- 0
  }
  if ((varnm == var_names[2] || varnm == var_names[3]) && (visit %in% exclude_visits)) {
    return(NULL)
  }
  if (roundmethod == "sas") {
    switch(statnm,
      N = length(stats::na.omit(datvec)),
      SE = format(
        tidytlg::roundSAS(stats::sd(datvec) / sqrt(length(stats::na.omit(datvec))), decimal + 2),
        nsmall = decimal + 2
      ),
      SD = format(
        tidytlg::roundSAS(stats::sd(datvec), decimal + 2),
        nsmall = decimal +
          2
      ),
      Mean = format(tidytlg::roundSAS(mean(datvec), decimal + 1), nsmall = decimal + 1),
      mean_sd = paste0(
        format(tidytlg::roundSAS(mean(datvec), decimal + 1), nsmall = decimal + 1),
        " (",
        format(
          tidytlg::roundSAS(stats::sd(datvec), decimal + 2),
          nsmall = decimal +
            2
        ),
        ")"
      ),
      Med = format(tidytlg::roundSAS(stats::median(datvec), decimal + 1), nsmall = decimal + 1),
      Min = format(tidytlg::roundSAS(min(datvec), decimal), nsmall = decimal),
      Max = format(tidytlg::roundSAS(max(datvec), decimal), nsmall = decimal)
    )
  } else {
    switch(statnm,
      N = length(stats::na.omit(datvec)),
      SE = format(round(stats::sd(datvec) / sqrt(length(stats::na.omit(datvec))), decimal + 2), nsmall = decimal + 2),
      SD = format(round(stats::sd(datvec), decimal + 2), nsmall = decimal + 2),
      Mean = format(round(mean(datvec), decimal + 1), nsmall = decimal + 1),
      mean_sd = paste0(
        format(round(mean(datvec), decimal + 1), nsmall = decimal + 1),
        " (",
        format(
          round(stats::sd(datvec), decimal + 2),
          nsmall = decimal +
            2
        ),
        ")"
      ),
      Med = format(round(stats::median(datvec), decimal + 1), nsmall = decimal + 1),
      Min = format(round(min(datvec), decimal), nsmall = decimal),
      Max = format(round(max(datvec), decimal), nsmall = decimal)
    )
  }
}

#' @name column_stats
#' @title Statistics within the column space
#' @description
#' A function used for obtaining statistics within the columns of your table. Used in change from baseline tables.
#' This takes the visit names as its row labels.
#' @param exclude_visits Vector of visit(s) for which you do not want the statistics displayed
#' in the baseline mean or change from baseline sections of the table.
#' @param var_names Vector of variable names to use instead of the default AVAL, CHG, BASE.
#' The first two elements are treated as main variables with full statistics, and the third element
#' is treated as the base variable. By default, the function expects these specific variable names in your data,
#' but you can customize them to match your dataset's column names.
#' @param stats A list with two components, `main` and `base`, that define the statistics to be calculated
#' for the main variables (default: AVAL, CHG) and the base variable (default: BASE).
#' Default for main variables: c(N = "N", mean = "Mean", SD = "SD", SE = "SE", Med = "Med", Min = "Min", Max = "Max")
#' Default for base variable: c(mean = "Mean")
#' You can customize these statistics by providing your own named vectors in the list. The names are used
#' internally for calculations, and the values are used as display labels in the table.
#' @export
column_stats <- function(exclude_visits = c("Baseline (DB)"),
                         var_names = c("AVAL", "CHG", "BASE"),
                         stats = list(
                           main = c(
                             N = "N", mean = "Mean", SD = "SD", SE = "SE",
                             Med = "Med", Min = "Min", Max = "Max"
                           ),
                           base = c(mean = "Mean")
                         )) {
  function(df, .var, .spl_context) {
    allcolsplvals <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
    statnm <- utils::tail(allcolsplvals, 1)
    varnm <- allcolsplvals[length(allcolsplvals) - 1]
    datvec <- df[[varnm]]
    decimalp <- utils::tail(df$dp, 1)
    datpervis <- split(datvec, df[[.var]]) ## ,var is AVISIT
    in_rows(
      .list = mapply(
        calc_one_visit,
        datvec = datpervis,
        decimal = decimalp,
        visit = names(datpervis),
        MoreArgs = list(
          statnm = statnm,
          varnm = varnm,
          exclude_visits = exclude_visits,
          var_names = var_names
        )
      ),
      .names = names(datpervis)
    )
  }
}

calc_N <- function(datvec, statnm, trt, varnm) {
  if (varnm != "AVAL") {
    return(NULL)
  }
  length(stats::na.omit(datvec))
}

column_N <- function(df, .var, .spl_context, id = "USUBJID", var_names = c("AVAL", "CHG", "BASE")) {
  allcolsplvals <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  statnm <- utils::tail(allcolsplvals, 1)
  varnm <- allcolsplvals[length(allcolsplvals) - 1]
  datvec <- unique(df[[id]])
  datpertrt <- split(datvec, df[[.var]]) ## ,var is Treatment
  in_rows(
    .list = mapply(calc_N, datvec = datpertrt, trt = names(datpertrt), MoreArgs = list(statnm = statnm, varnm = varnm)),
    .names = names(datpertrt)
  )
}

#' Non-blank Sentinel
#'
#' @keywords internal
non_blank_sentinel <- structure("", class = "non_blank_sentinel")

#' Get Control Subset
#'
#' Retrieves a subset of the DataFrame based on treatment variable and control group.
#'
#' @param df Data frame to subset.
#' @param trt_var Treatment variable name.
#' @param ctrl_grp Control group value.
#' @return Subset of the data frame.
#' @keywords internal
get_ctrl_subset <- function(df, trt_var, ctrl_grp) {
  df[df[[trt_var]] == ctrl_grp, ]
}


# sfunction to perform counting of records or subjects on an incoming df and .alt_df

#' Null Function
#'
#' A function that returns NULL.
#'
#' @return NULL
#' @keywords internal
null_fn <- function(...) {
  NULL
}


#' Create Alternative Data Frame
#'
#' Creates an alternative data frame based on the current split context.
#'
#' @param .spl_context Current split context.
#' @param .df_row Current data frame row.
#' @param denomdf Denominator data frame.
#' @param denom_by Denominator grouping variable.
#' @param id Identifier variable.
#' @param variables Variables to include in the analysis.
#' @param denom Denominator type.
#' @return Grand parent dataset.
#' @export
h_create_altdf <- function(.spl_context, .df_row, denomdf, denom_by = NULL, id, variables, denom) {
  ### parent df in the current row-split (all col splits are still in)
  pardf <- .spl_context$full_parent_df[[NROW(.spl_context)]]

  ## if no denomdf defined, use input if you want to use alt_source df, you better pass on the same dataframe as
  ## denomdf in the function call

  colsplit <- .spl_context$cur_col_split[[1]]
  if (length(colsplit) == 1 && tolower(colsplit) == "total") {
    colsplit <- NULL
  }

  if (is.null(denomdf) || denom %in% c("n_df", "n_rowdf")) {
    #### once we have the rtables version >= 0.6.12 -- is.null(denomdf) only will happen when build_table has been
    #### used without alt_counts_df argument denom options c('N_col', 'n_df', 'n_altdf', 'N_colgroup', 'n_rowdf',
    #### 'n_parentdf') note that n_altdf always has a non-null denomdf N_colgroup and n_parentdf will be handled
    #### separately n_parentdf in h_denom_parentdf N_colgroup with h_colexpr_substr

    denomdf <- unique(.df_row[, c(id, variables$strata, colsplit, denom_by), drop = FALSE])
  }

  # grand parent dataset starts of from denomdf -- not yet rowsplits this is for the risk diff columns to include all
  # subjects to start from
  gpardf <- denomdf

  nm_gpardf <- names(gpardf)

  sbgrpvar <- intersect(.spl_context$split, nm_gpardf)

  cursbgrp_value <- NULL

  if (!is.null(denom_by) && length(sbgrpvar) > 0) {
    ### assumption: the subgroup is the first variable in the row-split if this assumption is not valid ---
    ### re-design and let user pass in the subgroup variable
    sbgrpvar <- denom_by[1]
    cur_index <- which(.spl_context$split == sbgrpvar)
    if (length(cur_index) > 0) {
      cursbgrp_value <- .spl_context$value[[cur_index]]

      gpardf <- subset(denomdf, eval(denomdf[[sbgrpvar]] == cursbgrp_value))
    }
    if (length(cur_index) == 0) {
      # cat(paste('sbgrpvar', sbgrpvar)) cat(paste( unique(.spl_context$value), sep = ', '))
    }
  }

  ## note this is a rowsplit only, not yet column split
  return(gpardf)
}

#' No Data to Report String
#'
#' A constant string used when there is no data to display in a table.
#' This is used as a placeholder in tables when no data is available for a particular category.
#'
#' @return A character string with the value "No data to report".
#'
#' @export
#' @keywords internal
no_data_to_report_str <- "No data to report"


#' Update Factor
#'
#' Updates a factor variable in a data frame based on specified values.
#'
#' @param df Data frame containing the variable to update.
#' @param .var Variable name to update.
#' @param val Values to keep.
#' @param excl_levels Levels to exclude from the factor.
#' @return Updated data frame.
#' @export
h_update_factor <- function(df, .var, val = NULL, excl_levels = NULL) {
  if (!is.factor(df[[.var]]) || (is.null(val) && is.null(excl_levels))) {
    return(df)
  }

  if ((!is.null(val) && !is.null(excl_levels))) {
    stop("update_factor cannot be used with both val and excl_levels specified.")
  }

  all_levels <- levels(df[[.var]])

  if (!is.null(val)) {
    exclude_levels <- all_levels[!(all_levels %in% val)]
    remaining_levels <- setdiff(all_levels, exclude_levels)
  }
  if (!is.null(excl_levels)) {
    exclude_levels <- all_levels[all_levels %in% excl_levels]
    remaining_levels <- setdiff(all_levels, exclude_levels)
  }

  ## introduce level No data to report
  if (length(remaining_levels) == 0) {
    remaining_levels <- no_data_to_report_str
  }
  df[[.var]] <- factor(as.character(df[[.var]]), levels = remaining_levels)

  return(df)
}


#' Extract Substring from Column Expression
#'
#' Retrieves the substring from a column expression related to a variable component.
#'
#' get substring from col_expr related to var component
#' intended usage is on strings coming from .spl_context$cur_col_expr
#' these strings are of type '!(is.na(var) & var %in% 'xxx') & !(is.na(var2) & var2 %in% 'xxx')'
#'
#' @param var Variable to extract from the expression.
#' @param col_expr Column expression string.
#' @return Substring corresponding to the variable.
#' @export
h_colexpr_substr <- function(var, col_expr) {
  # reconstructing the strings is not an option as doesn't work for combined columns facets
  cur_col_expr <- as.character(col_expr)

  if (!grepl(var, cur_col_expr, fixed = TRUE)) {
    return(NULL)
  }

  z2 <- paste0("(!is.na(", var, ") & ", var, " %in%")
  start <- regexpr(z2, cur_col_expr, fixed = TRUE)
  end <- start + attr(start, "match.length") - 1
  z1 <- cbind(start, end)

  ### start of the string
  z1_start <- z1[1, 1]

  ### figure out what is the appropriate end expression has several & in string

  positions <- gregexpr("&", cur_col_expr, fixed = TRUE)
  start <- unlist(positions)
  end <- start + attr(positions[[1]], "match.length") - 1
  z3 <- cbind(start, end)[, 1]

  ### get the first & after the end of z3 ((!is.na(TRT01A) & TRT01A %in%)
  h <- z3 > z1[, 2]
  if (any(h)) {
    z4 <- which.max(h)
    z1_end <- z3[z4] - 3
  } else {
    z1_end <- nchar(cur_col_expr)
  }

  col_expr_substr <- substr(cur_col_expr, z1_start, z1_end)

  return(col_expr_substr)
}

#' Get Denominator Parent Data Frame
#'
#' Retrieves the parent data frame based on denominator.
#'
#' @param .spl_context Current split context.
#' @param denom Denominator type.
#' @param denom_by Denominator grouping variable.
#' @return Parent data frame.
#' @export
h_denom_parentdf <- function(.spl_context, denom, denom_by) {
  if (denom != "n_parentdf") {
    return(NULL)
  }
  if (is.null(denom_by)) {
    stop("denom_by must be specified when using denom = 'n_parentdf'.")
  }
  split <- .spl_context$split
  if (split[1] == "root" && !is.null(denom_by)) {
    denom_by <- c("root", denom_by)
  }
  split <- intersect(denom_by, split)
  parentdf <- .spl_context$full_parent_df[[length(split)]]
  return(parentdf)
}

#' Add New Levels to Data Frame
#'
#' Adds new factor levels to a specified variable in the data frame.
#'
#' @param df Data frame to update.
#' @param .var Variable to which new levels will be added.
#' @param new_levels List of new levels to add.
#' @param addstr2levs String to add to new levels.
#' @param new_levels_after Boolean, indicating if new levels should be added after existing levels.
#' @return Updated data frame.
#' @export
h_df_add_newlevels <- function(df, .var, new_levels, addstr2levs = NULL, new_levels_after) {
  varvec <- df[[.var]]

  levs <- if (is.factor(varvec)) levels(varvec) else sort(unique(varvec))

  if (!is.null(new_levels)) {
    ## assumption: new_levels[[1]] : names of the new levels new_levels[[2]] : values of the new levels
    if (length(new_levels[[1]]) != length(new_levels[[2]])) {
      stop("new_levels must be a list of length 2, second element must be a ",
           "list of same length as first element.")
    }
    if (any(duplicated(unlist(new_levels[[2]])))) {
      stop("unlist(new_levels[[2]]) contains duplicates: duplicate assignment ",
           "of a level to a new level is not allowed.")
    }

    sortnewlevs <- unlist(lapply(X = new_levels[[2]], FUN = function(x) {
      min(which(levs %in% x)) - 0.1
    }))

    if (new_levels_after) {
      sortnewlevs <- unlist(lapply(X = new_levels[[2]], FUN = function(x) {
        max(which(levs %in% x)) + 0.1
      }))
    }

    newlevs <- c(levs, new_levels[[1]])
    sortx <- c(seq_along(levs), sortnewlevs)

    newlevsx <- newlevs[order(sortx)]

    levs <- newlevsx

    ### add newlevels to df
    for (i in  seq_along(new_levels[[1]])) {
      levii <- unlist(new_levels[[2]][i])

      addi <- df[df[[.var]] %in% levii, ]
      addi[[.var]] <- new_levels[[1]][i]

      df <- dplyr::bind_rows(df, addi)
    }
  }

  levlabels <- levs
  if (!is.null(addstr2levs)) {
    levlabels <- paste0(levs, addstr2levs)
  }

  df[[.var]] <- factor(as.character(df[[.var]]), levels = levs, labels = levlabels)

  return(df)
}


#' Get Treatment Variable Reference Path
#'
#' Retrieves the treatment variable reference path from the provided context.
#'
#' @param ref_path Reference path for treatment variable.
#' @param .spl_context Current split context.
#' @param df Data frame.
#' @return List containing treatment variable details.
#' @export
h_get_trtvar_refpath <- function(ref_path, .spl_context, df) {
  checkmate::check_character(ref_path, min.len = 2L, names = "unnamed")
  checkmate::assert_true(length(ref_path) %% 2 == 0) # Even number of elements in ref_path.

  trt_var <- utils::tail(.spl_context$cur_col_split[[length(.spl_context$cur_col_split)]], n = 1)
  trt_var_refspec <- utils::tail(ref_path, n = 2)[1]

  checkmate::assert_true(identical(trt_var, trt_var_refspec))

  # current group and ctrl_grp
  cur_trt_grp <- utils::tail(.spl_context$cur_col_split_val[[length(.spl_context$cur_col_split_val)]], n = 1)
  ctrl_grp <- utils::tail(ref_path, n = 1)

  ### check that ctrl_grp is a level of the treatment variable, in case riskdiff is requested
  if (!ctrl_grp %in% levels(df[[trt_var]])) {
    stop(paste0(
      "control group specification in ref_path argument (",
      ctrl_grp,
      ") is not a level of your treatment group variable (",
      trt_var,
      ")."
    ))
  }
  return(list(trt_var = trt_var, trt_var_refspec = trt_var_refspec, cur_trt_grp = cur_trt_grp, ctrl_grp = ctrl_grp))
}


#' Update Data Frame Row
#'
#' Updates a row in the data frame based on various parameters.
#'
#' @param df_row Data frame row to update.
#' @param .var Variable name to update.
#' @param val Values to keep.
#' @param excl_levels Levels to exclude from the factor.
#' @param drop_levels Boolean, indicating if levels should be dropped.
#' @param new_levels New levels to add.
#' @param new_levels_after Boolean, indicating if new levels should be added after existing levels.
#' @param addstr2levs String to add to new levels.
#' @param label Label string.
#' @param label_map Mapping for labels.
#' @param labelstr Label string to replace.
#' @param label_fstr Format string for labels.
#' @param .spl_context Current split context.
#' @return List containing updated data frames and values.
#' @export
h_upd_dfrow <- function(
  df_row,
  .var,
  val,
  excl_levels,
  drop_levels,
  new_levels,
  new_levels_after,
  addstr2levs,
  label,
  label_map,
  labelstr,
  label_fstr,
  .spl_context
) {
  if (!is.null(label) && !is.null(label_map)) {
    stop("a_freq_j: label and label_map cannot be used together.")
  }

  if (!is.null(labelstr) && (!is.null(val) || !is.null(new_levels) || !is.null(excl_levels))) {
    stop("a_freq_j: val/excl_levels/new_levels cannot be used in a summarize_row_group call.")
  }

  if (!is.null(new_levels) && (is.null(.var) || is.na(.var))) {
    stop("When using new_levels, var must be provided in analyze call with a_freq_j.")
  }

  if (!is.null(val) && drop_levels == TRUE) {
    stop("argument val cannot be used together with drop_levels = TRUE.")
  }

  if (!is.null(val) && !is.null(excl_levels)) {
    stop("argument val and excl_levels cannot be used together.")
  }

  ## start making updates to factor information on incoming data

  if (!is.null(new_levels)) {
    df_row <- h_df_add_newlevels(
      df = df_row,
      .var = .var,
      new_levels = new_levels,
      new_levels_after = new_levels_after,
      addstr2levs = addstr2levs
    )
  }

  # if character var turn incoming data into factor, with levels from row-based df
  if (!is.na(.var) && is.character(df_row[[.var]]) && is.null(labelstr)) {
    levels <- sort(unique(df_row[[.var]]))
    df_row[[.var]] <- factor(df_row[[.var]], levels = levels)
    drop_levels <- FALSE
  }

  if (!is.null(labelstr)) {
    single_level <- labelstr

    if (!is.null(label_fstr) && grepl("%s", label_fstr, fixed = TRUE)) {
      single_level <- sprintf(label_fstr, single_level)
    }

    df_row[[.var]] <- as.character(df_row[[.var]])
    df_row[[.var]][!is.na(df_row[[.var]])] <- single_level

    df_row[[.var]] <- factor(as.character(df_row[[.var]]), levels = single_level)
    drop_levels <- FALSE
  }

  if (drop_levels) {
    obs_levs <- unique(df_row[[.var]])
    obs_levs <- intersect(levels(df_row[[.var]]), obs_levs)

    if (!is.null(excl_levels)) obs_levs <- setdiff(obs_levs, excl_levels)

    val <- obs_levs
    excl_levels <- NULL
  }

  if (!is.null(val)) {
    # do not yet restrict to val levels, only update factors to the requested levels df_row <-
    df_row <- h_update_factor(df_row, .var, val)
  }
  if (!is.null(excl_levels)) {
    # do not yet exclude the level specified in excl_levels, only update factors to remove requested levels df_row

    df_row <- h_update_factor(df_row, .var, excl_levels = excl_levels)
    val <- levels(df_row[[.var]])
  }

  ## update data with level coming from label -- important that this is done after restriction to val levels!!!
  if (!is.null(label)) {
    # similar to processing when labelstr
    single_level <- label
    df_row[[.var]] <- as.character(df_row[[.var]])
    df_row[[.var]][!is.na(df_row[[.var]])] <- single_level
    val <- label
    df_row[[.var]] <- factor(df_row[[.var]], levels = single_level)
  }

  # now update labels coming from label_map
  if (!is.null(label_map)) {
    split_info <- .spl_context[c("split", "value")]
    new_labels <- h_get_label_map(levels(df_row[[.var]]), label_map, .var, split_info)

    df_row[[.var]] <- factor(as.character(df_row[[.var]]), levels = levels(df_row[[.var]]), labels = new_labels)

    val <- new_labels
  }

  # now apply the updated factors from df_row to df as well due to drop_levels = TRUE can have different results when
  # applying all of the above to df
  col_expr <- .spl_context$cur_col_expr[[1]]
  df <- subset(df_row, eval(col_expr))

  return(list(df_row = df_row, df = df, val = val))
}


#' Get Label Map
#'
#' Maps labels based on the provided label map and split context.
#'
#' @param .labels Current labels.
#' @param label_map Mapping for labels.
#' @param .var Variable name.
#' @param split_info Current split information.
#' @return Mapped labels.
#' @export
h_get_label_map <- function(.labels, label_map, .var, split_info) {
  if (!is.null(label_map)) {
    if (!all(c("split", "value") %in% names(split_info))) {
      stop("split_info does not contain required elements.")
    }

    ### if label_map has a variable from row split, apply current splits on label_map tibble as well
    rowsplits <- split_info$split

    label_map_split <- intersect(names(label_map), rowsplits)

    if (!(length(label_map_split) == 0)) {
      for (i in seq_along(label_map_split)) {
        cursplvar <- label_map_split[i]
        cid <- match(cursplvar, rowsplits)
        cursplval <- split_info$value[cid]

        label_map <- label_map[label_map[[cursplvar]] == cursplval, ]
      }
    }

    if ("var" %in% names(label_map)) {
      label_map <- label_map[label_map[["var"]] == .var, ]
    }

    .labels <- label_map$label[match(.labels, label_map$value)]

    if (anyNA(.labels)) {
      stop("got a label map that doesn't provide labels for all values.")
    }
  }

  return(.labels)
}


#' A Frequency Data Preparation Function
#'
#' Prepares frequency data for analysis.
#'
#' @param df Data frame to prepare.
#' @param labelstr Label string.
#' @param .var Variable name.
#' @param val Values for analysis.
#' @param drop_levels Boolean, indicating if levels should be dropped.
#' @param excl_levels Levels to exclude.
#' @param new_levels New levels to add.
#' @param new_levels_after Boolean for adding new levels after existing ones.
#' @param addstr2levs String to add to new levels.
#' @param .df_row Current data frame row.
#' @param .spl_context Current split context.
#' @param .N_col Number of columns.
#' @param id Identifier variable.
#' @param denom Denominator types.
#' @param variables Variables to include in the analysis.
#' @param label Label string.
#' @param label_fstr Formatted label string.
#' @param label_map Mapping for labels.
#' @param .alt_df_full Alternative full data frame.
#' @param denom_by Denominator grouping variable.
#' @param .stats Statistics to compute.
#' @return List containing prepared data frames and values.
#' @export
h_a_freq_dataprep <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  drop_levels = FALSE,
  excl_levels = NULL,
  new_levels = NULL,
  new_levels_after = FALSE,
  addstr2levs = NULL,
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "N_colgroup", "n_rowdf", "n_parentdf"),
  variables,
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats
) {

  denom <- match.arg(denom)

  df <- df[!is.na(df[[.var]]), ]
  .df_row <- .df_row[!is.na(.df_row[[.var]]), ]

  # if no stats requested, get all stats
  .stats <- junco_get_stats("a_freq_j", stats_in = .stats, custom_stats_in = NULL)

  ### combine all preprocessing of incoming df/.df_row in one function do this outside stats derivation functions
  ### (s_freq_j/) use all of val/excl_levels/drop_levels//new_levels/ label/label_map/labelstr/label_fstr
  upd_dfrow <- h_upd_dfrow(
    df_row = .df_row,
    .var = .var,
    val = val,
    excl_levels = excl_levels,
    drop_levels = drop_levels,
    new_levels = new_levels,
    new_levels_after = new_levels_after,
    addstr2levs = addstr2levs,
    label = label,
    label_map = label_map,
    labelstr = labelstr,
    label_fstr = label_fstr,
    .spl_context = .spl_context
  )

  .df_row <- upd_dfrow$df_row
  df <- upd_dfrow$df

  val <- upd_dfrow$val

  # from here onwards proceed with drop_levels = FALSE action has already been done in h_upd_dfrow, and proper
  # observed values will be passed to val for s_freq_j
  drop_levels <- FALSE
  excl_levels <- NULL

  ### derive appropriate alt_df based upon .spl_context and .alt_df_full note that only row-based splits are done for
  ### now only for variables from the first split_rows_by
  alt_df <- h_create_altdf(
    .spl_context,
    .df_row,
    .alt_df_full,
    denom_by = denom_by,
    id = id,
    variables = variables,
    denom = denom
  )

  new_denomdf <- alt_df

  parentdf <- h_denom_parentdf(.spl_context, denom, denom_by)
  if (denom == "n_parentdf") {
    new_denomdf <- parentdf
  }

  return(list(
    df = df,
    .df_row = .df_row,
    val = val,
    drop_levels = drop_levels,
    excl_levels = excl_levels,
    alt_df = alt_df,
    parentdf = parentdf,
    new_denomdf = new_denomdf,
    .stats = .stats
  ))
}


#' Frequency Preparation in Rows
#'
#' Prepares frequency data in rows based on provided parameters.
#'
#' @param x_stats Statistics data.
#' @param .stats_adj Adjusted statistics.
#' @param .formats Format settings.
#' @param labelstr Label string.
#' @param label_fstr Formatted label string.
#' @param label Label string.
#' @param .indent_mods Indentation settings.
#' @param .labels_n Labels for statistics.
#' @param na_str String for NA values.
#' @return List containing prepared statistics, formats, labels, and indentation.
#' @export
h_a_freq_prepinrows <- function(
  x_stats,
  .stats_adj,
  .formats,
  labelstr,
  label_fstr,
  label,
  .indent_mods,
  .labels_n,
  na_str
) {
  # Fill in formatting defaults

  x_stats <- x_stats[.stats_adj]

  levels_per_stats <- lapply(x_stats, names)

  # Fill in formats/indents/labels with custom input and defaults
  .formats <- junco_get_formats_from_stats(.stats_adj, .formats, levels_per_stats)

  # lbls
  all_stats <- junco_get_stats("a_freq_j", stats_in = NULL, custom_stats_in = NULL)
  count_rr_stats <- grep("(count|rr_ci)", all_stats, value = TRUE)
  n_stats <- setdiff(all_stats, count_rr_stats)
  n_stats <- .stats_adj[.stats_adj %in% n_stats]

  if (length(.stats_adj) == 1 && length(n_stats) == 1) {
    if (!is.null(labelstr) && (!is.null(label))) {
      lbls <- label
    } else if (!is.null(labelstr) && !is.null(.labels_n)) {
      lbls <- .labels_n
    } else if (!is.null(labelstr) && is.null(label_fstr)) {
      lbls <- labelstr
    } else if (!is.null(labelstr) && !is.null(label_fstr) && grepl("%s", label_fstr, fixed = TRUE)) {
      lbls <- sprintf(label_fstr, labelstr)
    } else if (!is.null(label)) {
      lbls <- label
    } else {
      .labels <- .labels_n
      lbls <- junco_get_labels_from_stats(.stats_adj, .labels, levels_per_stats)
    }
  } else {
    if (length(n_stats) > 1 && is.null(.labels_n)) {
      msg <- paste0(
        "recommend to specify non-null .labels_n argument when multiple n_stats selected (",
        paste0(n_stats, collapse = ", "),
        ")"
      )
      message(msg)
    }
    ### labels from the non n-stat statistics are present on levels_per_stats labels for the n-stat statistics come
    ### from .labels_n (user) or from defaults
    .labels <- .labels_n
    lbls <- junco_get_labels_from_stats(.stats_adj, .labels, levels_per_stats)
  }
  .labels <- lbls
  .labels <- .unlist_keep_nulls(.labels)

  # indents
  .indent_mods_orig <- .indent_mods
  .indent_mods <- junco_get_indents_from_stats(.stats_adj, .indent_mods, levels_per_stats)

  # adjust indents when n_stat is included and no indents where passed by user
  if (length(n_stats) >= 1 && is.null(.indent_mods_orig)) {
    .indent_mods_new <- sapply(
      names(.indent_mods),
      FUN = function(x) {
        ret <- 0
        if (!(x %in% n_stats)) ret <- 1
        return(ret)
      },
      simplify = FALSE,
      USE.NAMES = TRUE
    )
    .indent_mods <- .indent_mods_new
  }

  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  # .format_na_strs processing if na_str = c(NA, NA, NA) this will ensure the ci (NA, NA, NA) will be represented as
  # NE (NE, NE) the value NE is defined as the default to replace NA in our jjcs format

  if (!is.null(na_str)) {
    # Create a list of na_str values for each format in .formats
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
    names(.format_na_strs) <- names(.formats)
  } else {
    .format_na_strs <- NULL
  }

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  return(list(
    x_stats = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  ))
}

#' Subset Combination
#'
#' Subsets a data frame based on specified combination criteria.
#'
#' @param df Data frame to subset.
#' @param combosdf Data frame containing combinations.
#' @param do_not_filter Variables to not filter.
#' @param filter_var Variable used for filtering.
#' @param flag_var Flag variable for filtering.
#' @param colid Column ID for identification.
#' @return Subsetted data frame.
#' @export
h_subset_combo <- function(df, combosdf, do_not_filter, filter_var, flag_var, colid) {
  ### this is the core code for subsetting to appropriate combo level
  if (!is.null(flag_var)) {
    df <- df[df[[flag_var]] == "Y", ]
  }

  # get the string related to combosdf text from colid it is the last part of the column id after the .  eg 'Active
  # Study Agent.Apalutamide.Thru 3 months' colid_str is 'Thru 3 months' colid_str <- stringr::str_split_i(colid,
  # '\\.', i = -1)
  colid_str <- tail(unlist(strsplit(colid, "\\.")), 1)

  filter_val <- combosdf[combosdf$valname == colid_str, ]$label

  if (!(colid_str %in% do_not_filter)) {
    df <- df |>
      dplyr::filter(get(filter_var) == filter_val)
  }

  return(df)
}

#' @title Create TableTree as DataFrame via gentlg
#'
#' @param tt TableTree object to convert to a data frame
#' @param fontspec Font specification object
#' @param string_map Unicode mapping for special characters
#' @param markup_df Data frame containing markup information
tt_to_tbldf <- function(
  tt,
  fontspec = font_spec("Times", 9L, 1),
  string_map = default_str_map,
  markup_df = dps_markup_df
) {
  if (!validate_table_struct(tt)) {
    stop(
      "invalid table structure. summarize_row_groups without ",
      "analyze below it in layout structure?"
    )
  }
  mpf <- matrix_form(
    tt,
    indent_rownames = FALSE,
    expand_newlines = FALSE,
    fontspec = fontspec
  )

  strmat <- mf_strings(mpf)
  strmat[, 1] <- gsub("^[[:space:]]+", "", strmat[, 1])
  nhl <- mf_nlheader(mpf)
  strbody <- strmat[-(1:nhl), , drop = FALSE]
  row_type <- apply(
    strbody,
    1,
    function(x) {
      nonempty <- nzchar(x)
      if (all(!nonempty)) {
        ## shouldn't ever happen
        "EMPTY"
      } else if (nonempty[1] && all(!nonempty[-1])) {
        # only 1st cell nonempty
        "HEADER"
      } else {
        if (x[1] == "N") {
          "N"
        } else {
          "VALUE"
        }
      }
    }
  )
  rowdf <- mf_rinfo(mpf)
  rinds <- mf_lgrouping(mpf)[-(1:nhl)] -
    mf_nrheader(mpf)
  indentme <- rowdf$indent[rinds]
  anbr <- cumsum(!is.na(c(0, utils::head(rowdf$trailing_sep, -1))))[rinds] + 1 ## so it starts at 1
  roworder <- seq_len(NROW(rowdf)) - (anbr - 1)
  newrows <- c(0, ifelse(utils::tail(anbr, -1) == utils::head(anbr, -1), 0, 1))

  strbody <- prep_strs_for_rtf(strbody, string_map, markup_df)
  tbldf <- as.data.frame(strbody)

  names(tbldf) <- c("label", paste("col", seq_len(ncol(tbldf) - 1)))
  emptycols <- tbldf[1, ]
  emptycols[1, ] <- ""

  tbldf <- cbind(
    tbldf,
    data.frame(
      row_type = row_type,
      anbr = anbr,
      indentme = indentme,
      roworder = roworder,
      newrows = newrows,
      stringsAsFactors = FALSE
    )
  )
  tbldf
}

brackets_to_rtf <- function(strs) {
  gsub("\\[\\[([^]]+)\\]\\]", "\\\\{\\1}", strs)
}

gutter_width <- .12 # inches

## this is for Times New Roman 9
mar_plus_gutters <- 2 + gutter_width

pg_width_by_orient <- function(landscape = FALSE) {
  fullpg <- ifelse(landscape, 11, 8.5)
  fullpg - mar_plus_gutters
}

tlg_type <- function(tt) {
  if (methods::is(tt, "list") && !methods::is(tt, "listing_df")) {
    tt <- tt[[1]]
  }
  if (methods::is(tt, "ggplot")) {
    ret <- "Figure"
  } else if (methods::is(tt, "VTableTree")) {
    ret <- "Table"
  } else if (methods::is(tt, "listing_df")) {
    ret <- "Listing"
  } else {
    stop(
      "unable to determine tlg type for object of class: ",
      paste(class(tt), collapse = ",")
    )
  }
  ret
}

mpf_to_colspan <- function(
  mpf,
  string_map = default_str_map,
  markup_df = dps_markup_df
) {
  if (!methods::is(mpf, "MatrixPrintForm")) {
    stop("figure out how to make this an mpf (MatrixPrintForm) first.")
  }
  strmat <- mf_strings(mpf)
  ## spaces in column header will get underlines, but we dont' want them to
  nhl <- mf_nlheader(mpf)
  strmat[seq_len(nhl - 1), ] <- gsub(
    "^[[:space:]]+$",
    "",
    strmat[seq_len(nhl - 1), ]
  )
  strmat[nhl, ] <- ifelse(nzchar(strmat[nhl, ]), strmat[nhl, ], " ")
  strmat <- prep_strs_for_rtf(strmat, string_map, markup_df)
  nspancols <- nhl - 1L
  if (nspancols > 0) {
    csph <- lapply(seq_len(nspancols), function(ii) {
      spns <- mf_spans(mpf)[ii, ]
      vals <- strmat[ii, ]
      jj <- 1 ## could start at 2 cause 1 is row label/topleft space but why complicate thigns
      ind <- 1
      myrle <- rle(vals)
      while (jj < length(vals)) {
        if (myrle$lengths[ind] == 1) {
          jj <- jj + 1
          ind <- ind + 1
        } else {
          sq <- seq(jj, jj + myrle$lengths[ind] - 1)
          valspns <- spns[sq]
          if (valspns[1] != length(sq)) {
            vals[sq] <- split_val_spans(vals[jj], valspns)
          }
          jj <- tail(sq, 1) + 1
          ind <- ind + 1
        }
      }
      vals
    })
  } else {
    csph <- NULL
  }

  list(colspan = csph, colheader = strmat[nhl, ])
}

split_val_spans <- function(val, spns) {
  if (val == "") {
    return(rep(val, length(spns)))
  }
  padvec <- rep("", length(spns))
  j <- 1
  padnum <- 0
  while (j < length(spns)) {
    onespn <- spns[j]
    if (padnum > 0) {
      padvec[j:(j + onespn - 1)] <- strrep(" ", padnum)
    }
    padnum <- padnum + 1
    j <- j + onespn
  }
  paste0(padvec, val, padvec)
}

partmpf_to_colinds <- function(fullmpf, partmpf) {
  stopifnot(
    mf_nlheader(fullmpf) == mf_nlheader(partmpf),
    mf_ncol(fullmpf) >= mf_ncol(partmpf)
  )
  nlh <- mf_nlheader(fullmpf)
  fullhdr <- mf_strings(fullmpf)[1:nlh, , drop = FALSE]
  parthdr <- mf_strings(partmpf)[1:nlh, , drop = FALSE]
  fullkeys <- apply(fullhdr, 2, paste, collapse = "", simplify = TRUE)
  ## hack to force first key to match uniquely
  fullkeys[1] <- paste(c("xxx", fullkeys[-1]), collapse = "")
  stopifnot(length(fullkeys) == length(unique(fullkeys)))
  partkeys <- apply(parthdr, 2, paste, collapse = "", simplify = TRUE)
  partkeys[1] <- fullkeys[1]
  match(partkeys, fullkeys)
}

subset_border_mat <- function(full_brdr, full_mpf, part_mpf) {
  if (is.null(full_brdr)) {
    return(NULL)
  }
  inds <- partmpf_to_colinds(full_mpf, part_mpf)
  full_brdr[, inds, drop = FALSE]
}


get_ncol <- function(tt) {
  if (is(tt, "listing_df") || is(tt, "VTableTree"))
    ncol(tt)
  else if (is(tt, "MatrixPrintForm"))
    mf_ncol(tt)
  else if (is.list(tt)) {
    if (is(tt[[1]], "MatrixPrintForm"))
      mf_ncol(tt[[1]])
    else
      ncol(tt[[1]])
  }
}

#' @name tt_to_tlgrtf
#' @title TableTree to .rtf Conversion
#' @description
#' A function to convert TableTree to .rtf
#' @details
#' This function aids in converting the rtables TableTree into the desired .rtf file.
#'
#' @param tt TableTree object to convert to RTF
#' @param file character(1). File to create, including path, but excluding
#' .rtf extension.
#' @param orientation Orientation of the output ("portrait" or "landscape")
#' @param colwidths Column widths for the table
#' @param label_width_ins Label width in inches
#' @param fontspec Font specification object
#' @param pg_width Page width in inches
#' @param margins Margins in inches (top, right, bottom, left)
#' @param paginate Whether to paginate the output
#' @param col_gap Column gap in spaces
#' @param verbose Whether to print verbose output
#' @param tlgtype Type of the output (Table, Listing, or Figure)
#' @param string_map Unicode mapping for special characters
#' @param markup_df Data frame containing markup information
#' @param ... Additional arguments passed to gentlg
#' @inheritParams tidytlg::gentlg
#' @param nosplitin list(row=, col=). Path elements whose children should not be paginated within
#' if it can be avoided. e.g., list(col="TRT01A") means don't split within treatment arms unless
#' all the associated columns don't fit on a single page.
#' @param combined_rtf logical(1). In the case where the result is broken up into multiple
#' parts due to width, should a combined rtf file also be created. Defaults to `FALSE`.
#' @param one_table logical(1). If `tt` is a (non-`MatrixPrintForm`) list,
#' should the parts be added to the rtf within a single table (`TRUE`, the
#' default) or as separate tables. End users will not generally need to set this.
#' @param border_mat matrix. A `m x k` matrix where m is the number of columns of `tt`
#'  and k is the number of lines the header takes up. See [tidytlg::add_bottom_borders]
#'  for what the matrix should contain. Users should only specify this when the
#'  default behavior does not meet their needs.
#' @import rlistings
#' @rdname tt_to_tlgrtf
#' @export
#' @seealso Used in all table and listing scripts
#' @note `file` should always include path. Path will be extracted
#' and passed separately to `gentlg`.
#' @note When `one_table` is `FALSE`, only the width of the row label
#'   pseudocolumn can be directly controlled due to a limitation in
#'   `tidytlg::gentlg`. The proportion of the full page that the first value
#'   in colwidths would take up is preserved and all other columns equally
#'   split the remaining available width. This will cause, e.g., the
#'   elements within the allparts rtf generated when `combined_rtf` is `TRUE`
#'   to differ visually from the content of the individual part rtfs.
#'
tt_to_tlgrtf <- function(
  tt,
  file = file.path(".", tolower(tlg_type(tt))),
  orientation = c("portrait", "landscape"),
  colwidths = def_colwidths(
    tt,
    fontspec,
    col_gap = col_gap,
    label_width_ins = label_width_ins,
    type = tlgtype
  ),
  label_width_ins = 2,
  watermark = NULL,
  pagenum = ifelse(tlgtype == "Listing", TRUE, FALSE),
  fontspec = font_spec("Times", 9L, 1.2),
  pg_width = pg_width_by_orient(orientation == "landscape"),
  margins = c(0, 0, 0, 0),
  paginate = tlg_type(tt) == "Table",
  col_gap = ifelse(tlgtype == "Listing", .5, 3),
  nosplitin = list(
    row = character(),
    col = character()
  ),
  verbose = FALSE,
  tlgtype = tlg_type(tt),
  string_map = default_str_map,
  markup_df = dps_markup_df,
  combined_rtf = FALSE,
  one_table = TRUE,
  border_mat = make_header_bordmat(obj = tt),
  ...
) {
  orientation <- match.arg(orientation)
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }

  if (tlgtype == "Listing" && nrow(tt) == 0) {
    dat <- as.list(c("No data to report", rep("", ncol(tt) - 1)))
    names(dat) <- names(tt)
    df <- as.data.frame(dat)
    var_labels(df) <- var_labels(tt)

    tt <- as_listing(
      df,
      key_cols = get_keycols(tt),
      disp_cols = listing_dispcols(tt)
    )
  }

  if (tlgtype == "Table" && fontspec$size == 8) {
    opts <- options(
      tidytlg.fontsize.table.footnote = 8,
      tidytlg.fontsize.table = 8
    )
    on.exit(options(opts), add = TRUE)
  }

  if (length(colwidths) == 1) {
    nc <- get_ncol(tt)
    tot_width <- page_lcpp(
      pg_width = pg_width,
      pg_height = 20, # don't care about this,
      font_family = fontspec$family,
      font_size = fontspec$size,
      lineheight = fontspec$lineheight,
      margins = c(0, 0, 0, 0),
      landscape = orientation == "landscape"
    )$cpp
    wdth_left <- tot_width - colwidths
    colwidths <- c(colwidths, rep(floor(wdth_left / nc), nc))
  }

  max_lwidth <- inches_to_spaces(label_width_ins, fontspec)
  if (colwidths[1] > max_lwidth) {
    colwidths[1] <- max_lwidth
  }

  if (!requireNamespace("tidytlg")) {
    stop("tidytlg not installed, cannot go out to rtf.")
  }

  if (paginate) {
    ## implies type Table
    if (tlgtype != "Table") {
      stop(
        "pagination is not currently supported for tlg types other than Table."
      )
    }
    if (methods::is(tt, "VTableTree")) {
      hdrmpf <- matrix_form(tt[1, ])
    } else if (methods::is(tt, "list") && methods::is(tt[[1]], "MatrixPrintForm")) {
      hdrmpf <- tt[[1]]
    } else {
      hrdmpf <- tt
    }
    pags <- paginate_to_mpfs(
      tt,
      fontspec = fontspec,
      landscape = orientation == "landscape",
      colwidths = colwidths,
      col_gap = col_gap,
      pg_width = pg_width,
      pg_height = NULL,
      margins = margins,
      lpp = NULL,
      nosplitin = nosplitin,
      verbose = verbose
    ) ##
    if (has_force_pag(tt)) {
      nslices <- which(
        cumsum(vapply(pags, mf_ncol, 1L)) == ncol(tt)
      )
      oldpags <- pags
      pags <- lapply(
        seq_len(nslices),
        function(ii) {
          inds <- seq(ii, by = nslices, length.out = length(oldpags) / nslices)
          oldpags[inds]
        }
      )
    }
    pag_bord_mats <- lapply(
      seq_along(pags),
      function(i) {
        if (methods::is(pags[[i]], "MatrixPrintForm")) {
          partmpf <- pags[[i]]
        } else {
          partmpf <- pags[[i]][[1]]
        }
        subset_border_mat(border_mat, hdrmpf, partmpf)
      }
    )
    ret <- lapply(
      seq_along(pags),
      function(i) {
        if (length(pags) > 1) {
          fmti <- paste0("%0", ceiling(log(length(pags), base = 10)), "d")
          fname <- paste0(file, "part", sprintf(fmti, i), "of", length(pags))
        } else {
          fname <- file
        }
        full_pag_i <- pags[[i]]
        if (
          is.list(full_pag_i) &&
            !methods::is(full_pag_i, "MatrixPrintForm")
        ) {
          pgi_for_cw <- full_pag_i[[1]]
        } else {
          pgi_for_cw <- full_pag_i
        }
        tt_to_tlgrtf(
          full_pag_i,
          file = fname,
          orientation = orientation,
          colwidths = j_mf_col_widths(pgi_for_cw),
          fontspec = fontspec,
          watermark = watermark,
          col_gap = col_gap,
          paginate = FALSE,
          tlgtype = tlgtype,
          string_map = string_map,
          markup_df = markup_df,
          border_mat = pag_bord_mats[[i]],
          ...
        )
      }
    )
    if (combined_rtf) {
      if (length(pags) > 1) {
        tt_to_tlgrtf(
          pags,
          file = paste0(file, "allparts"),
          orientation = orientation,
          fontspec = fontspec,
          watermark = watermark,
          col_gap = col_gap,
          paginate = FALSE,
          tlgtype = "Table",
          string_map = string_map,
          markup_df = markup_df,
          one_table = FALSE,
          ## gentlg isn't vectorized on column widths so we're SOL here...
          colwidths = colwidths, ## this is largely ignored see note in docs
          # colwidths are already on the pags since they are mpfs
          border_mat = pag_bord_mats,
          ...
        )
      } else { # only one page after pagination
        message(
          "Table ",
          basename(file),
          ": No combined RTF created, output fit within one part."
        )
      }
    }
    return(ret)
  }

  if (tlgtype == "Table") {
    if (is.list(tt) && !methods::is(tt, "MatrixPrintForm")) {
      df <- lapply(
        tt,
        tt_to_tbldf,
        fontspec = fontspec,
        string_map = string_map,
        markup_df = markup_df
      )
      if (one_table) {
        df <- do.call(
          rbind,
          lapply(
            seq_along(df),
            function(ii) {
              dfii <- df[[ii]]
              dfii$newpage <- 0
              if (ii > 1) {
                dfii$newpage[1] <- 1
              }
              dfii$indentme <- ifelse(dfii$indentme <= 1, 0, dfii$indentme - 1)
              dfii
            }
          )
        )
      }
    } else {
      df <- tt_to_tbldf(
        tt,
        fontspec = fontspec,
        string_map = string_map,
        markup_df = markup_df
      )
    }
  } else {
    df <- tt[, listing_dispcols(tt)]
  }

  ## we only care about the col labels here...
  if (tlgtype == "Table" && is.list(tt) && !methods::is(tt, "MatrixPrintForm")) {
    mpf <- tt[[1]]
    if (!one_table) {
      colinfo <- lapply(
        tt,
        mpf_to_colspan,
        markup_df = markup_df,
        string_map = string_map
      )
      csph <- lapply(colinfo, function(x) x$colspan)
      colheader <- lapply(colinfo, function(x) x$colheader)
    } else {
      colinfo <- mpf_to_colspan(
        mpf,
        markup_df = markup_df,
        string_map = string_map
      )
      csph <- colinfo$colspan
      colheader <- colinfo$colheader
    }
  } else if (methods::is(tt, "MatrixPrintForm")) {
    mpf <- tt
    colinfo <- mpf_to_colspan(
      mpf,
      markup_df = markup_df,
      string_map = string_map
    )
    csph <- colinfo$colspan
    colheader <- colinfo$colheader
  } else {
    mpf <- matrix_form(
      utils::head(tt, 1),
      indent_rownames = FALSE,
      expand_newlines = FALSE,
      fontspec = fontspec
    )
    colinfo <- mpf_to_colspan(
      mpf,
      markup_df = markup_df,
      string_map = string_map
    )
    csph <- colinfo$colspan
    colheader <- colinfo$colheader
  }

  fname <- basename(file)
  ## dirname on "table" returns "." so we're good using
  ## this unconditionally as opath
  fpath <- dirname(file)

  if (tlgtype == "Table") {
    colwidths <- cwidths_final_adj(
      labwidth_ins = label_width_ins,
      total_width = pg_width,
      colwidths = colwidths[-1]
    )
  }
  colwidths <- colwidths / sum(colwidths)
  # finite precision arithmetic is a dreamscape of infinite wonder...
  ## sum(rep(1/18, 18)) <= 1 is FALSE...
  if (sum(colwidths) > 1) {
    colwidths <- colwidths - 0.00000000001 ## much smaller than a twip = 1/20 printing point
  }

  if (!one_table &&
        is.list(tt) && !is(tt, "MatrixPrintForm") &&
        length(unique(vapply(tt, ncol, 1))) > 1) {
    ### gentlg is not vectorized on wcol.  x.x x.x x.x
    ### but it won't break if we only give it one number...
    ### Calling this an ugly hack is an insult to all the hard working hacks
    ### out there
    colwidths <- colwidths[1]
  }

  footer_val <- prep_strs_for_rtf(
    c(
      main_footer(mpf),
      prov_footer(mpf)
    ),
    string_map,
    markup_df
  )
  if (length(footer_val) == 0) {
    footer_val <- NULL
  }

  if (tlgtype == "Table" && is.data.frame(df)) {
    utils::write.csv(
      df,
      file = file.path(fpath, paste0(tolower(fname), ".csv")),
      row.names = FALSE
    )
  }

  tidytlg::gentlg(
    df,
    tlf = tlgtype,
    format = "rtf",
    idvars = if (tlgtype == "Listing") get_keycols(tt) else NULL,
    colspan = csph,
    file = fname,
    opath = fpath,
    colheader = colheader,
    title = prep_strs_for_rtf(
      main_title(mpf),
      string_map,
      markup_df
    ),
    footers = footer_val,
    orientation = orientation,
    wcol = colwidths,
    watermark = watermark,
    pagenum = pagenum,
    bottom_borders = border_mat,
    ...
  )
}

## NB x/(x+sum(colwidths)) = labwidth_ins/total_width
cwidths_final_adj <- function(labwidth_ins, total_width, colwidths) {
  prop <- labwidth_ins / total_width
  lwidth <- floor(prop / (1 - prop) * sum(colwidths))
  c(lwidth, colwidths)
}

muffwarn_fun <- function(w) {
  print("handling warnings")
  if (grepl("grid.Call(C_convert", w, fixed = TRUE)) {
    invokeRestart("muffleWarning")
  }
}

make_bordmat_row <- function(rowspns) {
  havespn <- rowspns > 1
  if (!any(havespn)) {
    return(rep(0, times = length(rowspns)))
  }

  pos <- 1
  ngrp <- 1
  ret <- numeric(length(rowspns))
  while (pos < length(rowspns)) {
    spnval <- rowspns[pos]
    if (spnval > 1) {
      multipos <- seq(pos, pos + spnval - 1)
      val <- ngrp
    } else {
      multipos <- pos
      val <- 0
    }
    ret[multipos] <- val
    pos <- pos + spnval
    ngrp <- ngrp + 1
  }
  ret
}

fixup_bord_mat <- function(brdmat, hstrs) {
  ## no lines between labels and their counts
  countcells <- matrix(
    grepl("N=", hstrs, fixed = TRUE),
    nrow = nrow(hstrs),
    ncol = ncol(hstrs)
  )

  countcoords <- which(countcells, arr.ind = TRUE)
  for (i in seq_len(nrow(countcoords))) {
    brdmat[countcoords[i, "row"] - 1, countcoords[i, "col"]] <- 0
  }

  brdmat[!nzchar(hstrs) | hstrs == " "] <- 0
  brdmat[nrow(brdmat), ] <- 1
  brdmat[seq_len(nrow(brdmat) - 1), 1] <- 0
  brdmat
}

.make_header_bordmat <- function(
  obj,
  mpf = matrix_form(utils::head(obj, 1), expand_newlines = FALSE)
) {
  spns <- mf_spans(mpf)
  nlh <- mf_nlheader(mpf)
  nrh <- mf_nrheader(mpf)
  stopifnot(nlh == nrh)

  hstrs <- mf_strings(mpf)[seq_len(nrh), , drop = FALSE]
  spns <- mf_spans(mpf)[seq_len(nrh), , drop = FALSE]

  brdmat <- do.call(
    rbind,
    lapply(
      seq_len(nrh),
      function(i) make_bordmat_row(spns[i, ])
    )
  )

  brdmat <- fixup_bord_mat(brdmat, hstrs)
  brdmat
}

setGeneric(
  "make_header_bordmat",
  function(
    obj,
    mpf = matrix_form(utils::head(obj, 1), expand_newlines = FALSE)
  ) {
    standardGeneric("make_header_bordmat")
  }
)

setMethod(
  "make_header_bordmat",
  c(obj = "ANY", mpf = "MatrixPrintForm"),
  .make_header_bordmat
)

setMethod(
  "make_header_bordmat",
  c(obj = "listing_df"),
  function(obj, mpf) matrix(1, nrow = 1, ncol = length(listing_dispcols(obj)))
)

setMethod(
  "make_header_bordmat",
  c(obj = "VTableTree", mpf = "missing"),
  function(obj, mpf) {
    make_header_bordmat(
      mpf = matrix_form(
        utils::head(obj, 1),
        expand_newlines = FALSE
      )
    )
  }
)

#' @name jj_complex_scorefun
#' @title Complex Scoring Function
#' @description
#' A function used for sorting AE tables (and others) as required.
#' @details
#' This sort function sorts as follows:
#' Takes all the columns from a specified spanning column header (default= colspan_trt) and sorts by the last treatment
#' column within this.
#' If no spanning column header variable exists (e.g you have only one active treatment arm and have decided to
#' remove the spanning header from your layout) it will sort by the first treatment column in your table.
#' This function is not really designed for tables that have sub-columns, however if users wish to override any
#' default sorting behavior, they can simply specify their own colpath to use for sorting on (default=NULL)
#' @param spanningheadercolvar name of spanning header variable that defines the active treatment columns.
#' If you do not have an active treatment spanning header column then user can define this as NA.
#' @param usefirstcol This allows you to just use the first column of the table to sort on.
#' @param colpath name of column path that is needed to sort by (default=NULL).
#' This overrides other arguments if specified
#' (except firstcat and lastcat which will be applied if requested on this colpath)
#' @param firstcat If you wish to put any category at the top of the list despite any n's user can specify here.
#' @param lastcat If you wish to put any category at the bottom of the list despite any n's user can specify here.
#' @export
#' @returns a function which can be used as a score function (scorefun in `sort_at_path`).
# @examples #result <- sort_at_path(result, c('root', 'AEBODSYS'), scorefun = jj_complex_scorefun())
#' @examples
#' ADAE <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   AEBODSYS = c(
#'     'SOC 1', 'SOC 2', 'SOC 1', 'SOC 2', 'SOC 2',
#'     'SOC 2', 'SOC 2', 'SOC 1', 'SOC 2', 'SOC 1'
#'   ),
#'   AEDECOD = c(
#'     'Coded Term 2', 'Coded Term 1', 'Coded Term 3', 'Coded Term 4',
#'     'Coded Term 4', 'Coded Term 4', 'Coded Term 5', 'Coded Term 3',
#'     'Coded Term 1', 'Coded Term 2'
#'   ),
#'   TRT01A = c(
#'     'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
#'     'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
#'   ),
#'   TRTEMFL = c('Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y')
#' )
#'
#' ADAE <- ADAE |>
#'   dplyr::mutate(TRT01A = as.factor(TRT01A))
#'
#' ADAE$colspan_trt <- factor(ifelse(ADAE$TRT01A == 'Placebo', ' ', 'Active Study Agent'),
#'   levels = c('Active Study Agent', ' ')
#' )
#'
#' ADAE$rrisk_header <- 'Risk Difference (%) (95% CI)'
#' ADAE$rrisk_label <- paste(ADAE$TRT01A, paste('vs', 'Placebo'))
#'
#' colspan_trt_map <- create_colspan_map(ADAE,
#'   non_active_grp = 'Placebo',
#'   non_active_grp_span_lbl = ' ',
#'   active_grp_span_lbl = 'Active Study Agent',
#'   colspan_var = 'colspan_trt',
#'   trt_var = 'TRT01A'
#' )
#'
#' ref_path <- c("colspan_trt", " ", "TRT01A", "Placebo")
#'
#' lyt <- basic_table() |>
#'   split_cols_by(
#'     'colspan_trt',
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by('TRT01A') |>
#'   split_cols_by('rrisk_header', nested = FALSE) |>
#'   split_cols_by(
#'     'TRT01A',
#'     labels_var = 'rrisk_label',
#'     split_fun = remove_split_levels('Placebo')
#'   ) |>
#'   analyze(
#'     'TRTEMFL',
#'     a_freq_j,
#'     show_labels = 'hidden',
#'     extra_args = list(
#'       method = 'wald',
#'       label = 'Subjects with >=1 AE',
#'       ref_path = ref_path,
#'       .stats = "count_unique_fraction"
#'     )
#'   ) |>
#'   split_rows_by('AEBODSYS',
#'     split_label = 'System Organ Class',
#'     split_fun = trim_levels_in_group('AEDECOD'),
#'     label_pos = 'topleft',
#'     section_div = c(' '),
#'     nested = FALSE
#'   ) |>
#'   summarize_row_groups(
#'     'AEBODSYS',
#'     cfun = a_freq_j,
#'     extra_args = list(
#'       method = 'wald',
#'       ref_path = ref_path,
#'       .stats = "count_unique_fraction"
#'     )
#'   ) |>
#'   analyze(
#'     'AEDECOD',
#'     afun = a_freq_j,
#'     extra_args = list(
#'       method = 'wald',
#'       ref_path = ref_path,
#'       .stats = "count_unique_fraction"
#'     )
#'   )
#'
#' result <- build_table(lyt, ADAE)
#'
#' result
#'
#' # now add sorting function to sort by AEBODSYS and AEDECOD within SOC
#' # using complex score function which sorts
#' # using the last active treatment column by default
#' result <- sort_at_path(
#'   result,
#'   c('root', 'AEBODSYS'),
#'   scorefun = jj_complex_scorefun()
#' )
#'
#' result <- sort_at_path(
#'   result,
#'   c('root', 'AEBODSYS', '*', 'AEDECOD'),
#'   scorefun = jj_complex_scorefun()
#' )
#'
#' result
#' @rdname complex_scoring_function
#' @aliases jj_complex_scorefun
jj_complex_scorefun <- function(
  spanningheadercolvar = "colspan_trt",
  usefirstcol = FALSE,
  colpath = NULL,
  firstcat = NULL,
  lastcat = NULL
) {
  paths <- NULL

  function(tt) {
    if (is.null(paths)) {
      paths <<- col_paths(tt)
      if (is.null(colpath)) {
        if (is.na(spanningheadercolvar)) {
          atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
          use_paths <- atrt_paths
          act_trt_lst <- paths[use_paths]
          first_list <- sapply(act_trt_lst, utils::head, 1)
          first_at_value <- utils::head(first_list, n = 1)
          colpath <<- first_at_value
        } else {
          atrt_paths <- vapply(paths, function(pth) pth[[1]] == spanningheadercolvar && pth[[2]] != " ", TRUE)
          use_paths <- atrt_paths
          act_trt_lst <- paths[use_paths]
          last_list <- sapply(act_trt_lst, utils::tail, 1)
          last_at_value <- utils::tail(last_list, n = 1)
          colpath <<- last_at_value
        }

        if (usefirstcol) {
          atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
          use_paths <- atrt_paths
          act_trt_lst <- paths[use_paths]
          first_list <- sapply(act_trt_lst, utils::head, 1)
          first_at_value <- utils::head(first_list, n = 1)
          colpath <<- first_at_value
        }
      }
    }
    score <- unlist(cell_values(tt, colpath = colpath), use.names = FALSE)[1]

    if (length(score) == 0) {
      score <- 1
    }

    if (!is.null(firstcat)) {
      if (obj_name(tt) == firstcat) {
        score <- Inf
      }
    }
    if (!is.null(lastcat)) {
      if (obj_name(tt) == lastcat) {
        score <- -99999
      }
    }
    if (obj_name(tt) == " ") {
      score <- -Inf
    }

    return(score)
  }
}

#' @name a_freq_combos_j
#'
#' @title Analysis function count and percentage in column design controlled by combosdf
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams a_freq_j
#'
#' @param combosdf The df which provides the mapping of facets to produce cumulative counts for .N_col.
#' @note: These extra records must then be removed from the numerator via the filter_var parameter
#' to avoid double counting of events.
#' @param do_not_filter A vector of facets (i.e., column headers), identifying headers for which
#' no filtering of records should occur.
#' That is, the numerator should contain cumulative counts.  Generally, this will be used for a
#' "Total" column, or something similar.
#' @param filter_var The variable which identifies the records to count in the numerator for any given column.
#' Generally, this will contain text matching the column header for the column associated with a given record.
#' @param flag_var Variable which identifies the occurrence (or first occurrence) of an event.
#' The flag variable is expected to have a value of "Y" identifying that the event should be counted, or NA otherwise.

#' @param denom (`string`)\cr
#' One of \cr
#' \itemize{
#' \item \strong{N_col} Column count, \cr
#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
#' (`.row_df` from the rtables splitting machinery).\cr
#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
#' This higher row-level split is specified in the argument `denom_by`.\cr
#' }
#' @param .formats (named 'character' or 'list')\cr
#' formats for the statistics.
#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
#' @export

a_freq_combos_j <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  # arguments specific to a_freq_combos_j
  combosdf = NULL,
  do_not_filter = NULL,
  filter_var = NULL,
  flag_var = NULL,
  # arguments specific to a_freq_combos_j till here
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats = "count_unique_denom_fraction",
  .formats = NULL,
  .labels_n = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3)
) {
  denom <- match.arg(denom)

  if (denom %in% c("n_altdf") && is.null(.alt_df_full)) {
    stop(".alt_df_full cannot be NULL when denom = n_altdf.")
  }

  if (!is.null(combosdf) && !all(c("valname", "label") %in% names(combosdf))) {
    stop("a_freq_combos_j: combosdf must have variables valname and label.")
  }

  res_dataprep <- h_a_freq_dataprep(
    df = df,
    labelstr = labelstr,
    .var = .var,
    val = val,
    drop_levels = FALSE,
    excl_levels = NULL,
    new_levels = NULL,
    new_levels_after = FALSE,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .N_col = .N_col,
    id = id,
    denom = denom,
    variables = NULL,
    label = label,
    label_fstr = label_fstr,
    label_map = label_map,
    .alt_df_full = .alt_df_full,
    denom_by = denom_by,
    .stats = .stats
  )
  # res_dataprep is list with elements
  # df .df_row val
  # drop_levels excl_levels
  # alt_df parentdf new_denomdf
  # .stats
  # make these elements available in current environment
  df <- res_dataprep$df
  .df_row <- res_dataprep$.df_row
  val <- res_dataprep$val
  drop_levels <- res_dataprep$drop_levels
  excl_levels <- res_dataprep$excl_levels
  alt_df <- res_dataprep$alt_df
  parentdf <- res_dataprep$parentdf
  new_denomdf <- res_dataprep$new_denomdf
  .stats <- .stats

  ## colid can be used to figure out if we're in the combo column or not
  colid <- .spl_context$cur_col_id[[1]]

  ### this is the core code for subsetting to appropriate combo level
  df <- h_subset_combo(
    df = df,
    combosdf = combosdf,
    do_not_filter = do_not_filter,
    filter_var = filter_var,
    flag_var = flag_var,
    colid = colid
  )

  ## the same s-function can be used as in a_freq_j
  x_stats <- s_freq_j(
    df,
    .var = .var,
    .df_row = .df_row,
    val = val,
    alt_df = new_denomdf,
    parent_df = new_denomdf,
    id = id,
    denom = denom,
    .N_col = .N_col,
    countsource = "df"
  )

  .stats_adj <- .stats

  res_prepinrows <- h_a_freq_prepinrows(
    x_stats,
    .stats_adj,
    .formats,
    labelstr,
    label_fstr,
    label,
    .indent_mods,
    .labels_n,
    na_str
  )
  # res_prepinrows is list with elements
  # x_stats .formats .labels .indent_mods .format_na_strs
  # make these elements available in current environment
  x_stats <- res_prepinrows$x_stats
  .formats <- res_prepinrows$.formats
  .labels <- res_prepinrows$.labels
  .indent_mods <- res_prepinrows$.indent_mods
  .format_na_strs <- res_prepinrows$.format_na_strs

  ### final step: turn requested stats into rtables rows
  in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )
}

#' Adding Labels To Variables For Model
#'
#' @param vars (`list`)\cr variables to use.
#' @param data (`data.frame`)\cr data to use.
#' @param x (`character`)\cr an element in vars.
#'
#' @name labels
#' @keywords internal
NULL

#' @describeIn labels checks if element in `vars` is not `NULL` and not empty.
h_is_specified <- function(x, vars) {
  !is.null(vars[[x]]) && (length(vars[[x]]) > 0)
}

#' @describeIn labels checks if element in vars is not NULL and exists in dataset.
h_is_specified_and_in_data <- function(x, vars, data) {
  h_is_specified(x, vars) && all(vars[[x]] %in% names(data))
}

#' @describeIn labels gets label for each element in vars.
h_check_and_get_label <- function(x, vars, data) {
  checkmate::assert_true(h_is_specified_and_in_data(x, vars, data))
  res <- NULL
  for (v in vars[[x]]) {
    label <- attr(data[[v]], "label")
    string <- ifelse(!is.null(label), label, v)
    res <- c(res, stats::setNames(string, v))
  }
  res
}

#' Extraction of Covariate Parts from Character Vector
#'
#' @param covariates (`character`)\cr specification in the usual way, see examples.
#'
#' @return Character vector of the covariates involved in `covariates` specification.
#' @keywords internal
h_get_covariate_parts <- function(covariates) {
  checkmate::assert_character(covariates, null.ok = TRUE)
  if (is.null(covariates)) {
    NULL
  } else {
    unique(unlist(strsplit(covariates, split = "\\*|:")))
  }
}

#' @describeIn labels returns the list of variables with labels.
h_labels <- function(vars, data) {
  checkmate::assert_list(vars)
  checkmate::assert_data_frame(data)
  labels <- list()
  labels$response <- h_check_and_get_label("response", vars, data)
  labels$id <- h_check_and_get_label("id", vars, data)
  labels$visit <- h_check_and_get_label("visit", vars, data)
  if (h_is_specified("arm", vars)) {
    labels$arm <- h_check_and_get_label("arm", vars, data)
  }
  if (h_is_specified("covariates", vars)) {
    vars$parts <- h_get_covariate_parts(vars$covariates)
    labels$parts <- h_check_and_get_label("parts", vars, data)
  }
  if (h_is_specified("weights", vars)) {
    labels$weights <- h_check_and_get_label("weights", vars, data)
  }
  return(labels)
}

#' Building Model Formula
#'
#' This builds the model formula which is used inside [fit_mmrm_j()] and provided
#' to [mmrm::mmrm()] internally. It can be instructive to look at the resulting
#' formula directly sometimes.
#'
#' @param vars (`list`)\cr variables to use in the model.
#' @param cor_struct (`string`)\cr specify the covariance structure to use.
#' @return Formula to use in [mmrm::mmrm()].
#' @export
#'
#' @examples
#' vars <- list(
#'   response = 'AVAL', covariates = c('RACE', 'SEX'),
#'   id = 'USUBJID', arm = 'ARMCD', visit = 'AVISIT'
#' )
#' build_formula(vars, 'auto-regressive')
#' build_formula(vars)
build_formula <- function(
  vars,
  cor_struct = c(
    "unstructured",
    "toeplitz",
    "heterogeneous toeplitz",
    "ante-dependence",
    "heterogeneous ante-dependence",
    "auto-regressive",
    "heterogeneous auto-regressive",
    "compound symmetry",
    "heterogeneous compound symmetry"
  )
) {
  checkmate::assert_list(vars)
  cor_struct <- match.arg(cor_struct)
  covariates_part <- paste(vars$covariates, collapse = " + ")
  arm_visit_part <- if (is.null(vars$arm)) {
    vars$visit
  } else {
    paste0(vars$arm, "*", vars$visit)
  }
  random_effects_fun <- switch(
    cor_struct,
    unstructured = "us",
    toeplitz = "toep",
    `heterogeneous toeplitz` = "toeph",
    `ante-dependence` = "ad",
    `heterogeneous ante-dependence` = "adh",
    `auto-regressive` = "ar1",
    `heterogeneous auto-regressive` = "ar1h",
    `compound symmetry` = "cs",
    `heterogeneous compound symmetry` = "csh"
  )
  random_effects_part <- paste0(random_effects_fun, "(", vars$visit, " | ", vars$id, ")")
  rhs_formula <- paste(arm_visit_part, "+", random_effects_part)
  if (covariates_part != "") {
    rhs_formula <- paste(covariates_part, "+", rhs_formula)
  }
  stats::as.formula(paste(vars$response, "~", rhs_formula))
}

#' Extract Least Square Means from `MMRM`
#'
#' Extracts the least square means from an `MMRM` fit.
#'
#' @param fit (`mmrm`)\cr result of [mmrm::mmrm()].
#' @inheritParams fit_mmrm_j
#' @param averages (`list`)\cr named list of visit levels which should be averaged
#'   and reported along side the single visits.
#' @param weights (`string`)\cr type of weights to be used for the least square means,
#'   see [emmeans::emmeans()] for details.
#' @return A list with data frames `estimates` and `contrasts`.
#'   The attributes `averages` and `weights` save the settings used.
#'
#' @export
get_mmrm_lsmeans <- function(fit, vars, conf_level, weights, averages = list()) {
  checkmate::assert_class(fit, "mmrm")
  checkmate::assert_list(averages, types = "character")
  emmeans_res <- h_get_emmeans_res(fit, vars, weights)

  # Get least square means estimates for single visits, and possibly averaged visits.
  estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
  if (length(averages)) {
    average_specs <- h_get_average_visit_specs(emmeans_res, vars, averages, fit)
    average_estimates <- h_get_spec_visit_estimates(emmeans_res, average_specs, conf_level)
    estimates <- rbind(estimates, average_estimates)
  }
  has_arm_var <- !is.null(vars$arm)
  if (!has_arm_var) {
    return(list(estimates = estimates))
  }
  # Continue with contrasts when we have an arm variable.
  contrast_specs <- h_single_visit_contrast_specs(emmeans_res, vars)
  contrast_estimates <- h_get_spec_visit_estimates(emmeans_res, contrast_specs, conf_level, tests = TRUE)
  if (length(averages)) {
    average_contrast_specs <- h_average_visit_contrast_specs(contrast_specs, averages)
    average_contrasts <- h_get_spec_visit_estimates(emmeans_res, average_contrast_specs, conf_level, tests = TRUE)
    contrast_estimates <- rbind(contrast_estimates, average_contrasts)
  }

  relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
  contrast_estimates <- merge(contrast_estimates, relative_reduc_df, by = c(vars$arm, vars$visit), sort = FALSE)
  contrast_estimates[[vars$arm]] <- factor(contrast_estimates[[vars$arm]])
  contrast_estimates[[vars$visit]] <- factor(contrast_estimates[[vars$visit]])
  structure(list(estimates = estimates, contrasts = contrast_estimates), averages = averages, weights = weights)
}

#' `MMRM` Analysis
#'
#' Does the `MMRM` analysis. Multiple other functions can be called on the result to produce
#' tables and graphs.
#'
#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `MMRM`.
#'   The following elements need to be included as character vectors and match corresponding columns
#'   in `data`:
#'
#'   - `response`: the response variable.
#'   - `covariates`: the additional covariate terms (might also include interactions).
#'   - `id`: the subject ID variable.
#'   - `arm`: the treatment group variable (factor).
#'   - `visit`: the visit variable (factor).
#'   - `weights`: optional weights variable (if `NULL` or omitted then no weights will be used).
#'
#'   Note that the main effects and interaction of `arm` and `visit` are by default
#'   included in the model.
#' @param data (`data.frame`)\cr with all the variables specified in
#'   `vars`. Records with missing values in any independent variables
#'   will be excluded.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param cor_struct (`string`)\cr specifying the covariance structure, defaults to
#'   `'unstructured'`. See the details.
#' @param averages_emmeans (`list`)\cr optional named list of visit levels which should be averaged
#'   and reported along side the single visits.
#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
#' @param ... additional arguments for [mmrm::mmrm()], in particular `reml` and options listed in
#'   [mmrm::mmrm_control()].
#'
#' @details Multiple different degree of freedom adjustments are available via the `method` argument
#'   for [mmrm::mmrm()]. In addition, covariance matrix adjustments are available via `vcov`.
#'   Please see [mmrm::mmrm_control()] for details and additional useful options.
#'
#'   For the covariance structure (`cor_struct`), the user can choose among the following options.
#'
#'   - `unstructured`: Unstructured covariance matrix. This is the most flexible choice and default.
#'        If there are `T` visits, then `T * (T+1) / 2` variance parameters are used.
#'   - `toeplitz`: Homogeneous Toeplitz covariance matrix, which uses `T` variance parameters.
#'   - `heterogeneous toeplitz`: Heterogeneous Toeplitz covariance matrix,
#'        which uses `2 * T - 1` variance parameters.
#'   - `ante-dependence`: Homogeneous Ante-Dependence covariance matrix, which uses `T` variance parameters.
#'   - `heterogeneous ante-dependence`: Heterogeneous Ante-Dependence covariance matrix,
#'        which uses `2 * T - 1` variance parameters.
#'   - `auto-regressive`: Homogeneous Auto-Regressive (order 1) covariance matrix,
#'        which uses 2 variance parameters.
#'   - `heterogeneous auto-regressive`: Heterogeneous Auto-Regressive (order 1) covariance matrix,
#'        which uses `T + 1` variance parameters.
#'   - `compound symmetry`: Homogeneous Compound Symmetry covariance matrix, which uses 2
#'        variance parameters.
#'   - `heterogeneous compound symmetry`: Heterogeneous Compound Symmetry covariance matrix, which uses
#'        `T + 1` variance parameters.
#'
#' @return A `tern_model` object which is a list with model results:
#'
#'   - `fit`: The `mmrm` object which was fitted to the data. Note that via `mmrm::component(fit, 'optimizer')`
#'       the finally used optimization algorithm can be obtained, which can be useful for refitting the model
#'       later on.
#'   - `cov_estimate`: The matrix with the covariance matrix estimate.
#'   - `diagnostics`: A list with model diagnostic statistics (REML criterion, AIC, corrected AIC, BIC).
#'   - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
#'        The attributes `averages` and `weights` save the settings used
#'        (`averages_emmeans` and `weights_emmeans`).
#'   - `vars`: The variable list.
#'   - `labels`: Corresponding list with variable labels extracted from `data`.
#'   - `cor_struct`: input.
#'   - `ref_level`: The reference level for the arm variable, which is always the first level.
#'   - `treatment_levels`: The treatment levels for the arm variable.
#'   - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
#'   - `additional`: List with any additional inputs passed via `...`
#'
#' @export
#'
#' @note This function has the `_j` suffix to distinguish it from [mmrm::fit_mmrm()].
#'   It is a copy from the `tern.mmrm` package and later will be replaced by [tern.mmrm::fit_mmrm()].
#'   No new features are included in this function here.
#'
#' @examples
#' mmrm_results <- fit_mmrm_j(
#'   vars = list(
#'     response = 'FEV1',
#'     covariates = c('RACE', 'SEX'),
#'     id = 'USUBJID',
#'     arm = 'ARMCD',
#'     visit = 'AVISIT'
#'   ),
#'   data = mmrm::fev_data,
#'   cor_struct = 'unstructured',
#'   weights_emmeans = 'equal',
#'   averages_emmeans = list(
#'     'VIS1+2' = c('VIS1', 'VIS2')
#'   )
#' )
fit_mmrm_j <- function(
  vars = list(response = "AVAL", covariates = c(), id = "USUBJID", arm = "ARM", visit = "AVISIT"),
  data,
  conf_level = 0.95,
  cor_struct = "unstructured",
  weights_emmeans = "counterfactual",
  averages_emmeans = list(),
  ...
) {
  labels <- h_labels(vars, data)
  formula <- build_formula(vars, cor_struct)
  weights <- if (!is.null(vars$weights)) data[[vars$weights]] else NULL

  fit <- mmrm::mmrm(formula = formula, data = data, weights = weights, reml = TRUE, ...)
  lsmeans <- get_mmrm_lsmeans(
    fit = fit,
    vars = vars,
    conf_level = conf_level,
    averages = averages_emmeans,
    weights = weights_emmeans
  )
  cov_estimate <- mmrm::VarCorr(fit)
  visit_levels <- rownames(cov_estimate)
  contrasts_from_visits <- match(visit_levels, lsmeans$contrasts[[vars$visit]])
  df <- stats::setNames(lsmeans$contrasts$df[contrasts_from_visits], visit_levels)
  results <- list(
    fit = fit,
    cov_estimate = cov_estimate,
    lsmeans = lsmeans,
    vars = vars,
    labels = labels,
    mse = diag(cov_estimate),
    df = df,
    cor_struct = cor_struct,
    ref_level = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[1],
    treatment_levels = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[-1],
    conf_level = conf_level,
    additional = list(...)
  )
  class(results) <- "tern_model"
  return(results)
}

#' Tabulation of Least Square Means Results
#'
#' @description `r lifecycle::badge('stable')`
#'
#' These functions can be used to produce tables from LS means, e.g. from [fit_mmrm_j()]
#' or [fit_ancova()].
#'
#' @note These functions have been forked from the `tern.mmrm` package. Additional features
#'   are:
#'
#'   * Additional `ref_path` argument for [summarize_lsmeans()]
#'   * The function is more general in that it also works for LS means results from ANCOVA
#'   * Additional statistic `diff_mean_est_ci` is returned
#'   * P-value sidedness can be chosen
#'
#' @name tabulate_lsmeans
#' @examples
#' result <- fit_mmrm_j(
#'   vars = list(
#'     response = 'FEV1',
#'     covariates = c('RACE', 'SEX'),
#'     id = 'USUBJID',
#'     arm = 'ARMCD',
#'     visit = 'AVISIT'
#'   ),
#'   data = mmrm::fev_data,
#'   cor_struct = 'unstructured',
#'   weights_emmeans = 'equal'
#' )
#'
#' df <- broom::tidy(result)
#'
#' s_lsmeans(df[8, ], .in_ref_col = FALSE)
#' s_lsmeans(df[8, ], .in_ref_col = FALSE, alternative = "greater", show_relative = "increase")
#'
#' dat_adsl <- mmrm::fev_data |>
#'   dplyr::select(USUBJID, ARMCD) |>
#'   unique()
#'
#' basic_table() |>
#'   split_cols_by("ARMCD") |>
#'   add_colcounts() |>
#'   split_rows_by("AVISIT") |>
#'   analyze(
#'     "AVISIT",
#'     afun = a_lsmeans,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     extra_args = list(
#'       .stats = c(
#'         "n",
#'         "adj_mean_se",
#'         "adj_mean_ci",
#'         "diff_mean_se",
#'         "diff_mean_ci"
#'       ),
#'       .labels = c(
#'         adj_mean_se = "Adj. LS Mean (Std. Error)",
#'         adj_mean_ci = "95% CI",
#'         diff_mean_ci = "95% CI"
#'       ),
#'       .formats = c(adj_mean_se = jjcsformat_xx("xx.x (xx.xx)")),
#'       alternative = "greater",
#'       ref_path = c("ARMCD", result$ref_level)
#'     )
#'   ) |>
#'   build_table(
#'     df = broom::tidy(result),
#'     alt_counts_df = dat_adsl
#'   )
NULL

#' @describeIn tabulate_lsmeans Helper method (for [broom::tidy()]) to prepare a `data.frame` from an
#'   `tern_model` object containing the least-squares means and contrasts.
#' @method tidy tern_model
#' @importFrom generics tidy
#' @export
tidy.tern_model <- function(x, ...) {
  # nolint
  vars <- x$vars
  estimates <- x$lsmeans$estimates
  df <- if (is.null(vars$arm)) {
    nams <- names(estimates)
    to_rename <- match(c("estimate", "se", "df", "lower_cl", "upper_cl"), nams)
    names(estimates)[to_rename] <- paste0(names(estimates)[to_rename], "_est")
    estimates
  } else {
    contrasts <- x$lsmeans$contrasts
    merge(x = estimates, y = contrasts, by = c(vars$visit, vars$arm), suffixes = c("_est", "_contr"), all = TRUE)
  }
  df[[vars$arm]] <- factor(df[[vars$arm]], levels = levels(estimates[[vars$arm]]))
  df[[vars$visit]] <- factor(df[[vars$visit]], levels = levels(estimates[[vars$visit]]))
  df$conf_level <- x$conf_level
  if (!is.null(x$mse)) {
    df$mse <- x$mse[df[[vars$visit]]]
  }
  if (!is.null(x$df)) {
    df$df <- x$df[df[[vars$visit]]]
  }
  df
}

#' @describeIn tabulate_lsmeans Statistics function which is extracting estimates from a tidied least-squares means
#'   data frame.
#' @inheritParams proposal_argument_convention
#' @export
s_lsmeans <- function(df,
                      .in_ref_col,
                      alternative = c("two.sided", "less", "greater"),
                      show_relative = c("reduction", "increase")) {
  alternative <- match.arg(alternative)
  show_relative <- match.arg(show_relative)
  if_not_ref <- function(x) if (.in_ref_col) character() else x
  list(
    n = df$n,
    adj_mean_se = c(df$estimate_est, df$se_est),
    adj_mean_ci = with_label(
      c(df$lower_cl_est, df$upper_cl_est),
      paste0("Adjusted Mean ", f_conf_level(df$conf_level))
    ),
    adj_mean_est_ci = with_label(
      c(df$estimate_est, df$lower_cl_est, df$upper_cl_est),
      paste0("Adjusted Mean (", f_conf_level(df$conf_level), ")")
    ),
    diff_mean_se = if_not_ref(c(df$estimate_contr, df$se_contr)),
    diff_mean_ci = with_label(
      if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
      paste0("Difference in Adjusted Means ", f_conf_level(df$conf_level))
    ),
    diff_mean_est_ci = with_label(
      if_not_ref(c(df$estimate_contr, df$lower_cl_contr, df$upper_cl_contr)),
      paste0("Difference in Adjusted Means (", f_conf_level(df$conf_level), ")")
    ),
    change = switch(
      show_relative,
      reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
      increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
    ),
    p_value = if_not_ref(switch(
      alternative,
      two.sided = with_label(df$p_value, "2-sided p-value"),
      less = with_label(df$p_value_less, "1-sided p-value (less)"),
      greater = with_label(df$p_value_greater, "1-sided p-value (greater)")
    ))
  )
}

#' @describeIn tabulate_lsmeans Formatted Analysis function to be used as `afun`
#' @export
a_lsmeans <- function(df,
                      ref_path,
                      .spl_context,
                      ...,
                      .stats = NULL,
                      .formats = NULL,
                      .labels = NULL,
                      .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_lsmeans,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "tabulate_lsmeans",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' @note: This has been forked from the `rbmi` package, mainly to support in addition
#'   the pooling of variance estimates.
rbmi_pool <- function(
  results,
  conf.level = 0.95,
  alternative = c("two.sided", "less", "greater"),
  type = c("percentile", "normal")
) {
  rbmi::validate(results)

  alternative <- match.arg(alternative)
  type <- match.arg(type)

  pool_type <- class(results$results)[[1]]
  checkmate::assert_true(identical(pool_type, "rubin"))

  results_transpose <- (utils::getFromNamespace("transpose_results", "rbmi"))(
    results$results,
    (utils::getFromNamespace("get_pool_components", "rbmi"))(pool_type)
  )

  pars <- lapply(
    results_transpose,
    function(x, ...) mod_pool_internal_rubin(x, ...),
    conf.level = conf.level,
    alternative = alternative,
    type = type,
    D = results$method$D
  )

  method <- pool_type

  ret <- list(
    pars = pars,
    conf.level = conf.level,
    alternative = alternative,
    N = length(results$results),
    method = method
  )
  class(ret) <- "pool"
  return(ret)
}

mod_pool_internal_rubin <- function(results, conf.level, alternative, type, D) {
  ests <- results$est
  ses <- results$se
  dfs <- results$df
  alpha <- 1 - conf.level

  # Note: Need to take median here, because in the MMRM case the d.f. will be slightly different for each imputed
  # data set analysis.
  v_com <- stats::median(dfs)

  res_rubin <- (utils::getFromNamespace("rubin_rules", "rbmi"))(ests = ests, ses = ses, v_com = v_com)

  ret <- (utils::getFromNamespace("parametric_ci", "rbmi"))(
    point = res_rubin$est_point,
    se = sqrt(res_rubin$var_t),
    alpha = alpha,
    alternative = alternative,
    qfun = stats::qt,
    pfun = stats::pt,
    df = res_rubin$df
  )
  # Here also return the pooled d.f.:
  ret$df <- res_rubin$df

  return(ret)
}

#' Workaround statistics function to add HR with CI
#'
#' This is a workaround for [tern::s_coxph_pairwise()], which adds a statistic
#' containing the hazard ratio estimate together with the confidence interval.
#'
#' @inheritParams proposal_argument_convention
#'
#'
#' @name coxph_hr
#' @order 1
NULL

#' @describeIn coxph_hr Statistics function forked from [tern::s_coxph_pairwise()].
#'   the difference is that:
#'   1) It returns the additional statistic `lr_stat_df` (log rank statistic with degrees of freedom).
#' @export
#' @order 3
#'
#' @importFrom survival Surv coxph survdiff
#'
#' @examples
#' adtte_f <- tern::tern_ex_adtte |>
#'   dplyr::filter(PARAMCD == "OS") |>
#'   dplyr::mutate(is_event = CNSR == 0)
#' df <- adtte_f |> dplyr::filter(ARMCD == 'ARM A')
#' df_ref <- adtte_f |> dplyr::filter(ARMCD == 'ARM B')
#'
#' s_coxph_hr(
#'   df = df,
#'   .ref_group = df_ref,
#'   .in_ref_col = FALSE,
#'   .var = 'AVAL',
#'   is_event = 'is_event',
#'   strata = NULL
#' )
s_coxph_hr <- function(
  df,
  .ref_group,
  .in_ref_col,
  .var,
  is_event,
  strata = NULL,
  control = control_coxph(),
  alternative = c("two.sided", "less", "greater")
) {
  checkmate::assert_string(.var)
  checkmate::assert_numeric(df[[.var]])
  checkmate::assert_logical(df[[is_event]])
  assert_df_with_variables(df, list(tte = .var, is_event = is_event))
  alternative <- match.arg(alternative)
  pval_method <- control$pval_method
  ties <- control$ties
  conf_level <- control$conf_level

  if (.in_ref_col) {
    return(list(
      pvalue = with_label(list(), paste0("p-value (", pval_method, ")")),
      lr_stat_df = list(),
      hr = list(),
      hr_ci = with_label(list(), f_conf_level(conf_level)),
      hr_ci_3d = with_label(list(), paste0("Hazard Ratio (", f_conf_level(conf_level), ")")),
      n_tot = list(),
      n_tot_events = list()
    ))
  }
  data <- rbind(.ref_group, df)
  group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))

  df_cox <- data.frame(tte = data[[.var]], is_event = data[[is_event]], arm = group)
  if (is.null(strata)) {
    formula_cox <- survival::Surv(tte, is_event) ~ arm
  } else {
    formula_cox <- stats::as.formula(paste0(
      "survival::Surv(tte, is_event) ~ arm + strata(",
      paste(strata, collapse = ","),
      ")"
    ))
    df_cox <- cbind(df_cox, data[strata])
  }
  cox_fit <- survival::coxph(formula = formula_cox, data = df_cox, ties = ties)
  sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)
  original_survdiff <- survival::survdiff(formula_cox, data = df_cox)
  log_rank_stat <- original_survdiff$chisq

  # See survival::survdiff for the d.f. calculation.
  etmp <- if (is.matrix(original_survdiff$exp)) {
    apply(original_survdiff$exp, 1, sum)
  } else {
    original_survdiff$exp
  }
  log_rank_df <- (sum(1 * (etmp > 0))) - 1
  # Check the consistency of the d.f. with the p-value returned by survival::survdiff.
  log_rank_pvalue <- stats::pchisq(log_rank_stat, log_rank_df, lower.tail = FALSE)
  checkmate::assert_true(all.equal(log_rank_pvalue, original_survdiff$pvalue))

  pval <- switch(
    pval_method,
    wald = sum_cox$waldtest["pvalue"],
    `log-rank` = log_rank_pvalue,
    likelihood = sum_cox$logtest["pvalue"]
  )

  # Handle one-sided alternatives.
  if (alternative != "two.sided") {
    right_direction <- if (alternative == "less") {
      sum_cox$conf.int[1, 1] < 1
    } else {
      sum_cox$conf.int[1, 1] >= 1
    }
    pval <- if (right_direction) {
      pval / 2
    } else {
      1 - pval / 2
    }
  }

  list(
    pvalue = with_label(unname(pval), paste0("p-value (", pval_method, ")")),
    lr_stat_df = unname(c(log_rank_stat, log_rank_df)),
    hr = sum_cox$conf.int[1, 1],
    hr_ci = with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),
    hr_ci_3d = with_label(
      c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])),
      paste0("Hazard Ratio (", f_conf_level(conf_level), ")")
    ),
    n_tot = sum_cox$n,
    n_tot_events = sum_cox$nevent
  )
}

#' @describeIn coxph_hr Formatted analysis function which is used as `afun`.
#'
#' @examples
#' library(dplyr)
#'
#' adtte_f <- tern::tern_ex_adtte |>
#'   filter(PARAMCD == "OS") |>
#'   mutate(is_event = CNSR == 0)
#'
#' df <- adtte_f |> filter(ARMCD == 'ARM A')
#' df_ref_group <- adtte_f |> filter(ARMCD == 'ARM B')
#'
#' basic_table() |>
#'   split_cols_by(var = 'ARMCD', ref_group = 'ARM A') |>
#'   add_colcounts() |>
#'   analyze("AVAL",
#'     afun = s_coxph_hr,
#'     extra_args = list(is_event = 'is_event'),
#'     var_labels = 'Unstratified Analysis',
#'     show_labels = 'visible'
#'   ) |>
#'   build_table(df = adtte_f)
#'
#'   basic_table() |>
#'   split_cols_by(var = 'ARMCD', ref_group = 'ARM A') |>
#'   add_colcounts() |>
#'   analyze("AVAL",
#'           afun = s_coxph_hr,
#'           extra_args = list(is_event = 'is_event',
#'                             strata = 'SEX',
#'                             control = tern::control_coxph(pval_method = 'wald')),
#'           var_labels = 'Unstratified Analysis',
#'           show_labels = 'visible'
#'   ) |>
#'   build_table(df = adtte_f)
#' @export
#' @order 2
a_coxph_hr <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_coxph_hr,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "coxph_hr",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Tabulation of RBMI Results
#'
#' @description `r lifecycle::badge('stable')`
#'
#' These functions can be used to produce tables from RBMI.
#'
#' @name tabulate_rbmi
#'
#' @note These functions have been forked from `tern.rbmi`. Additional features are:
#'
#' * Additional `ref_path` argument.
#' * Extraction of variance statistics in the `tidy()` method.
#' * Adapted to `rbmi` forked functions update with more than two treatment groups.
NULL

#' @describeIn tabulate_rbmi Helper function to produce data frame with results
#'   of pool for a single visit.
#'
#' @param x (`list`)\cr is a list of pooled object from `rbmi` analysis results.
#'   This list includes analysis results, confidence level, hypothesis testing type.
#' @param visit_name (`string`)\cr single visit level.
#' @param group_names (`character`)\cr group levels.
#' @return The `data.frame` with results of pooled analysis for a single visit.
#'
#' @export
h_tidy_pool <- function(x, visit_name, group_names) {
  checkmate::assert_list(x)
  checkmate::assert_string(visit_name)
  checkmate::assert_character(group_names)

  ref_name <- paste0("lsm_", group_names[1], "_", visit_name)
  ref <- x[[ref_name]]

  list2df <- \(l) with(l, data.frame(est, ci_l = ci[1], ci_u = ci[2], se, pvalue, df))

  var_name <- paste0("var_", visit_name)
  var <- if (var_name %in% names(x)) {
    # This is the case for ANCOVA.
    list2df(x[[var_name]])
  } else {
    # This is the case for MMRM.
    var_names <- paste0("var_", group_names[-1], "_", visit_name)
    checkmate::assert_subset(var_names, names(x))
    var_dfs <- lapply(x[var_names], list2df)
    var <- do.call(rbind, var_dfs)
  }

  contr_names <- paste0("trt_", group_names[-1], "_", visit_name)
  contr_dfs <- lapply(x[contr_names], list2df)
  contr <- do.call(rbind, contr_dfs)

  alt_names <- paste0("lsm_", group_names[-1], "_", visit_name)
  alt_dfs <- lapply(x[alt_names], list2df)
  alt <- do.call(rbind, alt_dfs)

  df_ref <- data.frame(
    visit = visit_name,
    group = group_names[1],
    est = ref$est,
    se_est = ref$se,
    lower_cl_est = ref$ci[1],
    upper_cl_est = ref$ci[2],
    est_contr = NA_real_,
    se_contr = NA_real_,
    lower_cl_contr = NA_real_,
    upper_cl_contr = NA_real_,
    p_value = NA_real_,
    relative_reduc = NA_real_,
    mse = NA_real_,
    df = NA_real_,
    stringsAsFactors = FALSE
  )
  df_alt <- data.frame(
    visit = visit_name,
    group = group_names[-1],
    est = alt$est,
    se_est = alt$se,
    lower_cl_est = alt$ci_l,
    upper_cl_est = alt$ci_u,
    est_contr = contr$est,
    se_contr = contr$se,
    lower_cl_contr = contr$ci_l,
    upper_cl_contr = contr$ci_u,
    p_value = contr$pvalue,
    relative_reduc = contr$est / df_ref$est,
    mse = var$est,
    df = var$df,
    stringsAsFactors = FALSE
  )
  rbind(df_ref, df_alt)
}

#' Helper method (for [`broom::tidy()`]) to prepare a data frame from an
#'   `pool` `rbmi` object containing the LS means and contrasts and multiple visits
#'
#' @method tidy pool
#' @param x (`pool`) is a list of pooled object from `rbmi` analysis results. This list includes
#' analysis results, confidence level, hypothesis testing type.
#' @param visits (`character`)\cr all visit levels. Otherwise too hard to guess this.
#' @param ... Additional arguments. Not used. Needed to match generic signature only.
#' @importFrom generics tidy
#' @export
#' @keywords internal
#' @return A `data.frame`.
tidy.pool <- function(x, visits, ...) {
  ls_raw <- x$pars

  has_lsm <- grepl("^lsm_", names(ls_raw))
  has_first_visit <- grepl(paste0("_", visits[1]), names(ls_raw), fixed = TRUE)
  is_lsm_first_visit <- has_lsm & has_first_visit

  group_names <- names(ls_raw)[is_lsm_first_visit]
  group_names <- gsub(pattern = "^lsm_", replacement = "", x = group_names)
  group_names <- gsub(pattern = paste0("_", visits[1]), replacement = "", x = group_names, fixed = TRUE)

  spl <- rep(visits, each = length(ls_raw) / length(visits))

  ls_split <- split(ls_raw, spl)

  ls_df <- mapply(
    FUN = h_tidy_pool,
    x = ls_split,
    visit_name = visits,
    MoreArgs = list(group_names = group_names),
    SIMPLIFY = FALSE
  )

  result <- do.call(rbind, unname(ls_df))

  result$visit <- factor(result$visit, levels = visits)
  result$group <- factor(result$group, levels = group_names)
  result$conf_level <- x$conf.level

  result
}

#' @describeIn tabulate_rbmi Statistics function which is extracting estimates
#'   from a tidied RBMI results data frame.
#'
#' @param df (`data.frame`)\cr input with LS means results.
#' @param .in_ref_col (`flag`)\cr whether reference column is specified.
#' @param show_relative (`string`)\cr 'reduction' if (`control - treatment`, default)
#'   or 'increase' (`treatment - control`) of relative change from baseline?
#' @return A list of statistics extracted from a tidied LS means data frame.
#' @export
s_rbmi_lsmeans <- function(df, .in_ref_col, show_relative = c("reduction", "increase")) {
  checkmate::assert_flag(.in_ref_col)

  show_relative <- match.arg(show_relative)
  if_not_ref <- function(x) if (.in_ref_col) character() else x
  list(
    adj_mean_se = c(df$est, df$se_est),
    adj_mean_ci = with_label(c(df$lower_cl_est, df$upper_cl_est), f_conf_level(df$conf_level)),
    diff_mean_se = if_not_ref(c(df$est_contr, df$se_contr)),
    diff_mean_ci = with_label(
      if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
      f_conf_level(df$conf_level)
    ),
    change = switch(
      show_relative,
      reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
      increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
    ),
    p_value = if_not_ref(df$p_value),
    additional_title_row = NULL
  )
}

#' @describeIn tabulate_rbmi Formatted Analysis function which is used as `afun`.
#'
#' @inheritParams proposal_argument_convention
#' @export
a_rbmi_lsmeans <- function(
  df,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_rbmi_lsmeans,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "tabulate_rbmi",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Helpers for Processing Least Square Means
#'
#' @param fit result of model fitting function, e.g. [mmrm::mmrm()] or [stats::lm()].
#' @inheritParams fit_mmrm_j
#' @param averages (`list`)\cr optional named list of visit levels which should be averaged
#'   and reported along side the single visits.
#' @param weights (`string`)\cr argument from [emmeans::emmeans()], 'counterfactual' by default.
#' @param specs (`list`)\cr list of least square means specifications, with
#'   elements `coefs` (coefficient list) and `grid` (corresponding `data.frame`).
#' @param emmeans_res (`list`)\cr initial `emmeans` result from [h_get_emmeans_res()].
#'
#' @name lsmeans_helpers
#' @keywords internal
NULL

#' @describeIn lsmeans_helpers returns a list with
#'   `object` (`emmGrid` object containing `emmeans` results) and `grid`
#'   (`data.frame` containing the potential arm and the visit variables
#'   together with the sample size `n` for each combination).
h_get_emmeans_res <- function(fit, vars, weights) {
  data_complete <- stats::model.frame(fit)
  checkmate::assert_data_frame(data_complete)
  checkmate::assert_list(vars)

  emmeans_object <- emmeans::emmeans(fit, data = data_complete, specs = c(vars$visit, vars$arm), weights = weights)

  # Save grid with renamed number of subjects column.
  visit_arm_grid <- emmeans_object@grid
  wgt_index <- match(".wgt.", names(visit_arm_grid))
  names(visit_arm_grid)[wgt_index] <- "n"
  visit_arm_grid$n <- as.integer(visit_arm_grid$n)

  list(object = emmeans_object, grid = visit_arm_grid)
}

#' @describeIn lsmeans_helpers constructs average of visits specifications.
h_get_average_visit_specs <- function(emmeans_res, vars, averages, fit) {
  visit_grid <- emmeans_res$grid[[vars$visit]]
  model_frame <- stats::model.frame(fit)
  averages_list <- list()
  visit_vec <- n_vec <- c()
  if (!is.null(vars$arm)) {
    arm_grid <- emmeans_res$grid[[vars$arm]]
    arm_vec <- c()
  }
  for (i in seq_along(averages)) {
    average_label <- names(averages)[i]
    visits_average <- averages[[i]]
    checkmate::assert_subset(visits_average, choices = levels(visit_grid))
    which_visits_in_average <- visit_grid %in% visits_average
    average_coefs <- as.integer(which_visits_in_average) / length(visits_average)
    zero_coefs <- numeric(length = length(average_coefs))

    if (is.null(vars$arm)) {
      averages_list[[average_label]] <- average_coefs
      visit_vec <- c(visit_vec, average_label)
      is_in_subset <- (model_frame[[vars$visit]] %in% visits_average)
      this_n <- length(unique(model_frame[is_in_subset, vars$id]))
      n_vec <- c(n_vec, this_n)
    } else {
      for (this_arm in levels(arm_grid)) {
        this_coefs <- zero_coefs
        arm_average_label <- paste(this_arm, average_label, sep = ".")
        which_arm <- arm_grid == this_arm
        this_coefs[which_arm] <- average_coefs[which_arm]
        averages_list[[arm_average_label]] <- this_coefs
        arm_vec <- c(arm_vec, this_arm)
        visit_vec <- c(visit_vec, average_label)
        is_in_subset <- (model_frame[[vars$arm]] == this_arm) & (model_frame[[vars$visit]] %in% visits_average)
        this_n <- length(unique(model_frame[is_in_subset, vars$id]))
        n_vec <- c(n_vec, this_n)
      }
    }
  }
  if (is.null(vars$arm)) {
    averages_grid <- data.frame(visit = visit_vec, n = n_vec)
    names(averages_grid) <- c(vars$visit, "n")
  } else {
    averages_grid <- data.frame(arm = arm_vec, visit = visit_vec, n = n_vec)
    names(averages_grid) <- c(vars$arm, vars$visit, "n")
  }
  list(coefs = averages_list, grid = averages_grid)
}

#' @describeIn lsmeans_helpers estimates least square means as a `data.frame`
#'   given specifications.
#'
#' @note The difference here compared to the original [tern.mmrm::h_get_spec_visit_estimates()]
#'   function is that additional arguments for [emmeans::contrast()] can be passed via the
#'   Once this has been added to the `tern.mmrm` package then its functions can be used instead.
#'
#' @param tests (`flag`)\cr whether to add test results to the estimates.
#' @param ... additional arguments for [emmeans::contrast()].
h_get_spec_visit_estimates <- function(emmeans_res, specs, conf_level, tests = FALSE, ...) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_list(specs)
  checkmate::assert_number(conf_level)
  checkmate::assert_flag(tests)

  conts <- emmeans::contrast(emmeans_res$object, specs$coefs, ...)
  cis <- stats::confint(conts, level = conf_level)
  res <- cbind(
    specs$grid,
    data.frame(estimate = cis$estimate, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL)
  )
  if (tests) {
    conts_df <- as.data.frame(conts)
    res$t_stat <- conts_df$t.ratio
    res$p_value <- conts_df$p.value
    res$p_value_less <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = TRUE)
    res$p_value_greater <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = FALSE)
  }
  res
}

#' @describeIn lsmeans_helpers estimates least square means for single visits.
h_get_single_visit_estimates <- function(emmeans_res, conf_level) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_number(conf_level)

  cis <- stats::confint(emmeans_res$object, level = conf_level)
  cbind(
    emmeans_res$grid[, setdiff(names(emmeans_res$grid), "n"), drop = FALSE],
    data.frame(estimate = cis$emmean, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL),
    emmeans_res$grid[, "n", drop = FALSE]
  )
}

#' @describeIn lsmeans_helpers constructs `data.frame` with
#'   relative reduction vs. reference arm based on single visit estimates.
#' @param estimates (`data.frame`)\cr single visit least square mean estimates.
h_get_relative_reduc_df <- function(estimates, vars) {
  checkmate::assert_data_frame(estimates)
  checkmate::assert_list(vars)

  ref_arm_level <- estimates[[vars$arm]][1L]
  ref_estimates <- estimates[estimates[[vars$arm]] == ref_arm_level, c(vars$visit, "estimate")]
  names(ref_estimates)[2L] <- "ref"
  result <- merge(estimates[estimates[[vars$arm]] != ref_arm_level, ], ref_estimates, by = vars$visit, sort = FALSE)
  result$relative_reduc <- (result$ref - result$estimate) / result$ref
  result[, c(vars$visit, vars$arm, "relative_reduc")]
}

#' @describeIn lsmeans_helpers constructs single visit contrast specifications.
h_single_visit_contrast_specs <- function(emmeans_res, vars) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_list(vars)

  emmeans_res$grid$index <- seq_len(nrow(emmeans_res$grid))

  grid_by_visit <- split(emmeans_res$grid, emmeans_res$grid[[vars$visit]])

  arm_levels <- emmeans_res$object@levels[[vars$arm]]
  ref_arm_level <- arm_levels[1L]
  zeros_coefs <- numeric(nrow(emmeans_res$grid))
  overall_list <- list()
  arm_vec <- visit_vec <- c()
  for (j in seq_along(grid_by_visit)) {
    this_grid <- grid_by_visit[[j]]
    ref_index <- which(this_grid[[vars$arm]] == ref_arm_level)
    this_visit <- names(grid_by_visit)[j]
    this_ref_coefs <- zeros_coefs
    this_ref_coefs[this_grid$index[ref_index]] <- -1
    this_list <- list()
    for (i in seq_len(nrow(this_grid))[-ref_index]) {
      this_coefs <- this_ref_coefs
      this_coefs[this_grid$index[i]] <- 1
      this_arm <- as.character(this_grid[[vars$arm]][i])
      arm_vec <- c(arm_vec, this_arm)
      visit_vec <- c(visit_vec, this_visit)
      this_label <- paste(this_arm, this_visit, sep = ".")
      this_list[[this_label]] <- this_coefs
    }
    overall_list <- c(overall_list, this_list)
  }

  grid <- data.frame(arm = arm_vec, visit = visit_vec)
  names(grid) <- c(vars$arm, vars$visit)
  list(coefs = overall_list, grid = grid)
}

#' @describeIn lsmeans_helpers constructs average visits contrast specifications,
#'   given the `specs` for single visit contrasts and the averages required.
h_average_visit_contrast_specs <- function(specs, averages) {
  arm_visit_grid <- specs$grid
  arm_visit_grid$index <- seq_len(nrow(arm_visit_grid))
  grid_by_arm <- split(arm_visit_grid, arm_visit_grid[, 1L])
  overall_list <- list()
  arm_vec <- visit_vec <- c()
  for (j in seq_along(grid_by_arm)) {
    this_arm <- names(grid_by_arm)[j]
    this_grid <- grid_by_arm[[j]]
    for (i in seq_along(averages)) {
      average_label <- names(averages)[i]
      visits_average <- averages[[i]]
      which_visits_in_average <- this_grid[, 2L] %in% visits_average
      averaged_indices <- this_grid$index[which_visits_in_average]
      this_comb <- paste(this_arm, average_label, sep = ".")
      averaged_coefs <- colMeans(do.call(rbind, specs$coefs[averaged_indices]))
      overall_list[[this_comb]] <- averaged_coefs
      arm_vec <- c(arm_vec, this_arm)
      visit_vec <- c(visit_vec, average_label)
    }
  }

  grid <- data.frame(arm = arm_vec, visit = visit_vec)
  names(grid) <- names(arm_visit_grid[, c(1, 2)])

  list(coefs = overall_list, grid = grid)
}

#' Function Factory to Create Padded In Rows Content
#'
#' @param length_out (`count` or `NULL`)\cr full length which should be padded
#'   by `NA` which will be printed as empty strings.
#' @param label (`string`)\cr row label to be used for the first row only.
#'
#' @return The function of `content` and `.formats`.
#' @keywords internal
pad_in_rows_fct <- function(length_out = NULL, label = "") {
  checkmate::assert_count(length_out, null.ok = TRUE)
  checkmate::assert_string(label)

  function(content, .formats) {
    content_list <- as.list(content)
    if (!is.null(length_out)) {
      missing_length <- length_out - length(content_list)
      if (missing_length > 0) {
        content_list <- c(content_list, rep(NA, missing_length))
      }
    }
    in_rows(
      .list = content_list,
      .names = as.character(seq_along(content_list)),
      .labels = c(
        label,
        rep(
          "",
          length(content_list) -
            1L
        )
      ),
      .formats = .formats,
      .format_na_strs = ""
    )
  }
}

#' First Level Column Split for LS Means Wide Table Layouts
#'
#' @inheritParams proposal_argument_convention
#'
#' @keywords internal
lsmeans_wide_first_split_fun_fct <- function(include_variance) {
  checkmate::assert_flag(include_variance)

  post_fun <- function(ret, spl, fulldf, .spl_context) {
    if (include_variance) {
      short_split_result(
        reference_group = "Reference Group",
        testing_group = "Testing Group",
        variance = "",
        comparison = "Testing - Reference",
        fulldf = fulldf
      )
    } else {
      short_split_result(
        reference_group = "Reference Group",
        testing_group = "Testing Group",
        comparison = "Testing - Reference",
        fulldf = fulldf
      )
    }
  }
  make_split_fun(post = list(post_fun))
}

#' Second Level Column Split for LS Means Wide Table Layouts
#'
#' @inheritParams proposal_argument_convention
#' @param include_pval (`flag`)\cr whether to include the p-value column.
#'
#' @keywords internal
lsmeans_wide_second_split_fun_fct <- function(pval_sided, conf_level, include_pval) {
  checkmate::assert_flag(include_pval)

  post_fun <- function(ret, spl, fulldf, .spl_context) {
    colset <- .spl_context[nrow(.spl_context), "value"][[1]]
    if (colset %in% c("reference_group", "testing_group")) {
      short_split_result(treatment = "Treatment", n = "N", lsmean = "LS Mean", fulldf = fulldf)
    } else if (colset == "variance") {
      short_split_result(mse = "M. S. Error", df = "Error DF", fulldf = fulldf)
    } else {
      if (include_pval) {
        short_split_result(
          lsmean = "LS Mean",
          se = "SE",
          ci = f_conf_level(conf_level),
          pval = paste0(abs(as.numeric(pval_sided)), "-sided p-value~[super a]"),
          fulldf = fulldf
        )
      } else {
        short_split_result(lsmean = "LS Mean", se = "SE", ci = f_conf_level(conf_level), fulldf = fulldf)
      }
    }
  }
  make_split_fun(post = list(post_fun))
}

#' Content Row Analysis Function for LS Means Wide Table Layouts
#'
#' @inheritParams proposal_argument_convention
#' @param variables (`list`)\cr see [fit_ancova()] for required variable
#'   specifications.
#' @param ref_level (`string`)\cr the reference level of the treatment arm variable.
#' @param treatment_levels (`character`)\cr the non-reference levels of the treatment arm
#'   variable.
#' @param pval_sided (`string`)\cr either '2' for two-sided or '1' for 1-sided with greater than
#'   control or '-1' for 1-sided with smaller than control alternative hypothesis.
#' @param formats (`list`)\cr including `lsmean`, `mse`, `df`, `lsmean_diff`, `se`,
#'   `ci`, `pval` formats.
#'
#' @details This assumes a lot of structure of the layout, and is only intended to be used inside
#'   [summarize_lsmeans_wide()], please see there for the layout structure that is needed.
#'
#' @keywords internal
lsmeans_wide_cfun <- function(
  df,
  labelstr,
  .spl_context,
  variables,
  ref_level,
  treatment_levels,
  pval_sided = c("2", "1", "-1"),
  conf_level,
  formats
) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  pad_in_rows <- pad_in_rows_fct(length_out = length(treatment_levels), label = labelstr)
  if (this_col_split[1] %in% c("reference_group", "testing_group")) {
    this_level <- if (this_col_split[1] == "reference_group") {
      ref_level
    } else {
      treatment_levels
    }
    has_this_level <- df[[variables$arm]] %in% this_level
    if (this_col_split[2] == "treatment") {
      pad_in_rows(this_level, .formats = "xx")
    } else if (this_col_split[2] == "n") {
      pad_in_rows(df$n[has_this_level], .formats = "xx")
    } else {
      pad_in_rows(df$estimate_est[has_this_level], .formats = formats$lsmean)
    }
  } else if (this_col_split[1] == "variance") {
    has_trt <- df[[variables$arm]] %in% treatment_levels
    all_the_same <- (length(unique(df$mse[has_trt])) == 1) && (length(unique(df$df[has_trt])) == 1)
    # Note: We only take the first value, because in this ANCOVA case they are identical and we don't want to
    # repeat it in the table.
    inds <- if (all_the_same) 1 else seq_len(sum(has_trt))
    if (this_col_split[2] == "mse") {
      pad_in_rows(df$mse[has_trt][inds], .formats = formats$mse)
    } else {
      pad_in_rows(df$df[has_trt][inds], .formats = formats$df)
    }
  } else {
    has_trt <- df[[variables$arm]] %in% treatment_levels
    switch(this_col_split[2],
      "lsmean" = pad_in_rows(df$estimate_contr[has_trt], .formats = formats$lsmean_diff),
      "se" = pad_in_rows(df$se_contr[has_trt], .formats = formats$se),
      "ci" = pad_in_rows(
        tern::combine_vectors(df$lower_cl_contr[has_trt], df$upper_cl_contr[has_trt]),
        .formats = formats$ci
      ),
      "pval" = {
        pval_sided <- match.arg(pval_sided)
        pval_col <- switch(pval_sided, `2` = "p_value", `1` = "p_value_greater", `-1` = "p_value_less")
        pad_in_rows(df[[pval_col]][has_trt], .formats = formats$pval)
      }
    )
  }
}

#' Layout Generating Function for LS Means Wide Table Layouts
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams lsmeans_wide_cfun
#' @param lyt empty layout, i.e. result of [rtables::basic_table()]
#' @param include_variance (`flag`)\cr whether to include the variance statistics
#'   (M.S. error and d.f.).
#' @param include_pval (`flag`)\cr whether to include the p-value column.
#'
#' @return Modified layout.
#' @export
#' @examples
#' variables <- list(
#'   response = 'FEV1',
#'   covariates = c('RACE', 'SEX'),
#'   arm = 'ARMCD',
#'   id = 'USUBJID',
#'   visit = 'AVISIT'
#' )
#' fit <- fit_ancova(
#'   vars = variables,
#'   data = mmrm::fev_data,
#'   conf_level = 0.9,
#'   weights_emmeans = 'equal'
#' )
#' anl <- broom::tidy(fit)
#' basic_table() |>
#'   summarize_lsmeans_wide(
#'     variables = variables,
#'     ref_level = fit$ref_level,
#'     treatment_levels = fit$treatment_levels,
#'     pval_sided = '2',
#'     conf_level = 0.8
#'   ) |>
#'   build_table(df = anl)
summarize_lsmeans_wide <- function(
  lyt,
  variables,
  ref_level,
  treatment_levels,
  conf_level,
  pval_sided = "2",
  include_variance = TRUE,
  include_pval = TRUE,
  formats = list(
    lsmean = jjcsformat_xx("xx.x"),
    mse = jjcsformat_xx("xx.x"),
    df = jjcsformat_xx("xx."),
    lsmean_diff = jjcsformat_xx("xx.x"),
    se = jjcsformat_xx("xx.xx"),
    ci = jjcsformat_xx("(xx.xx, xx.xx)"),
    pval = jjcsformat_pval_fct(0)
  )
) {
  # Check that all required format elements are present in the formats parameter
  checkmate::assert_names(
    names(formats),
    must.include = c("lsmean", "mse", "df", "lsmean_diff", "se", "ci", "pval"),
    .var.name = "formats"
  )
  lyt |>
    split_cols_by(
      variables$arm,
      split_fun = lsmeans_wide_first_split_fun_fct(include_variance = include_variance)
    ) |>
    split_cols_by(
      variables$arm,
      split_fun = lsmeans_wide_second_split_fun_fct(
        include_pval = include_pval,
        pval_sided = pval_sided,
        conf_level = conf_level
      )
    ) |>
    split_rows_by(variables$visit, section_div = "") |>
    summarize_row_groups(
      var = variables$arm,
      cfun = lsmeans_wide_cfun,
      extra_args = list(
        variables = variables,
        ref_level = ref_level,
        treatment_levels = treatment_levels,
        pval_sided = pval_sided,
        conf_level = conf_level,
        formats = formats
      )
    )
}

#' Get default statistical methods and their associated formats, labels, and indent modifiers
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @note These functions have been copied from the `tern` package file
#'   `utils_default_stats_formats_labels.R` from GitHub development version 0.9.7.9017.
#'   Slight modifications have been applied to enhance functionality:
#'
#'   * `tern_get_stats` added the `tern_stats` argument to avoid hardcoding within the function's body.
#'   * `tern_get_labels_from_stats` is more careful when receiving partial `labels_in`
#'      and partial `label_attr_from_stats`.
#'
#'   Once these features are included in the `tern` package, this file could be removed from
#'   the `junco` package, and the functions could be used from the `tern` namespace directly.
#'
#' @name tern_default_stats_formats_labels
NULL


# Utility function used to separate custom stats (user-defined functions) from defaults
.split_std_from_custom_stats <- function(stats_in) {
  out <- list(default_stats = NULL, custom_stats = NULL, all_stats = NULL)
  if (is.list(stats_in)) {
    is_custom_fnc <- sapply(stats_in, is.function)
    checkmate::assert_list(
      stats_in[is_custom_fnc],
      types = "function",
      names = "named"
    )
    out[["custom_stats"]] <- stats_in[is_custom_fnc]
    out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc])
    all_stats <- names(stats_in) # to keep the order
    all_stats[!is_custom_fnc] <- out[["default_stats"]]
    out[["all_stats"]] <- all_stats
  } else {
    out[["default_stats"]] <- out[["all_stats"]] <- stats_in
  }
  out
}

# Utility function to apply statistical functions
.apply_stat_functions <- function(
  default_stat_fnc,
  custom_stat_fnc_list,
  args_list
) {
  # Default checks
  checkmate::assert_function(default_stat_fnc)
  checkmate::assert_list(
    custom_stat_fnc_list,
    types = "function",
    null.ok = TRUE,
    names = "named"
  )
  checkmate::assert_list(args_list)

  # Checking custom stats have same formals
  if (!is.null(custom_stat_fnc_list)) {
    fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]]
    for (fnc in custom_stat_fnc_list) {
      if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) {
        stop(
          "The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ",
          "as the default statistical function. In this case your custom function has ",
          names(formals(fnc))[[1]],
          " as first parameter, while the default function has ",
          fundamental_call_to_data,
          "."
        )
      }
      if (!any(names(formals(fnc)) == "...")) {
        stop(
          "The custom statistical function needs to have `...` as a parameter to accept additional arguments. ",
          "In this case your custom function does not have `...`."
        )
      }
    }
  }

  # Applying
  out_default <- do.call(default_stat_fnc, args = args_list)
  out_custom <- lapply(
    custom_stat_fnc_list,
    function(fnc) do.call(fnc, args = args_list)
  )

  # Merging
  c(out_default, out_custom)
}

#' @describeIn tern_default_stats_formats_labels Get statistics available for a given method
#'   group (analyze function).
#' @keywords internal
tern_get_stats <- function(
  method_groups = "analyze_vars_numeric",
  stats_in = NULL,
  custom_stats_in = NULL,
  add_pval = FALSE,
  tern_defaults = tern_default_stats
) {
  checkmate::assert_character(method_groups)
  checkmate::assert_character(stats_in, null.ok = TRUE)
  checkmate::assert_character(custom_stats_in, null.ok = TRUE)
  checkmate::assert_flag(add_pval)

  # Default is still numeric
  if (any(method_groups == "analyze_vars")) {
    method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"
  }

  type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks

  # Defaults for loop
  out <- NULL

  # Loop for multiple method groups
  for (mgi in method_groups) {
    if (mgi %in% names(tern_defaults)) {
      out_tmp <- tern_defaults[[mgi]]
    } else {
      stop(
        "The selected method group (",
        mgi,
        ") has no default statistical method."
      )
    }
    out <- unique(c(out, out_tmp))
  }

  # Add custom stats
  out <- c(out, custom_stats_in)

  # If you added pval to the stats_in you certainly want it
  if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
    stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]

    # Must be only one value between choices
    checkmate::assert_choice(
      stats_in_pval_value,
      c("pval", "pval_counts", "pvalue")
    )

    # Mismatch with counts and numeric
    if (
      any(grepl("counts", method_groups)) &&
        stats_in_pval_value != "pval_counts" ||
        any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval"
    ) {
      # nolint
      stop(
        "Inserted p-value (",
        stats_in_pval_value,
        ") is not valid for type ",
        type_tmp,
        ". Use ",
        paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),
        " instead."
      )
    }

    # Lets add it even if present (thanks to unique)
    add_pval <- TRUE
  }

  # Mainly used in "analyze_vars" but it could be necessary elsewhere
  if (isTRUE(add_pval)) {
    if (any(grepl("counts", method_groups))) {
      out <- unique(c(out, "pval_counts"))
    } else {
      out <- unique(c(out, "pval"))
    }
  }

  # Filtering for stats_in (character vector)
  if (!is.null(stats_in)) {
    out <- intersect(stats_in, out) # It orders them too
  }

  # If intersect did not find matches (and no pval?) -> error
  if (length(out) == 0) {
    stop(
      "The selected method group(s) (",
      paste0(method_groups, collapse = ", "),
      ")",
      " do not have the required default statistical methods:\n",
      paste0(stats_in, collapse = " ")
    )
  }

  out
}

#' @describeIn tern_default_stats_formats_labels Get formats corresponding to a list of statistics.
#' @keywords internal
tern_get_formats_from_stats <- function(
  stats,
  formats_in = NULL,
  levels_per_stats = NULL,
  tern_defaults = tern_default_formats
) {
  checkmate::assert_character(stats, min.len = 1)
  # It may be a list if there is a function in the formats
  if (checkmate::test_list(formats_in, null.ok = TRUE)) {
    checkmate::assert_list(formats_in, null.ok = TRUE)
    # Or it may be a vector of characters
  } else {
    checkmate::assert_character(formats_in, null.ok = TRUE)
  }
  checkmate::assert_list(levels_per_stats, null.ok = TRUE)

  # If unnamed formats given as formats_in and same number of stats, use one format per stat
  if (
    !is.null(formats_in) &&
      length(formats_in) == length(stats) &&
      is.null(names(formats_in)) &&
      is.null(levels_per_stats)
  ) {
    out <- as.list(formats_in) |> stats::setNames(stats)
    return(out)
  }

  # If levels_per_stats not given, assume one row per statistic
  if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) |> stats::setNames(stats)

  # Apply custom formats
  out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults)

  # Default to NULL if no format
  case_input_is_not_stat <- unlist(out, use.names = FALSE) == unlist(levels_per_stats, use.names = FALSE)
  out[names(out) == out | case_input_is_not_stat] <- list(NULL)

  out
}

#' @describeIn tern_default_stats_formats_labels Get labels corresponding to a list of statistics.
#' @keywords internal
tern_get_labels_from_stats <- function(
  stats,
  labels_in = NULL,
  levels_per_stats = NULL,
  label_attr_from_stats = NULL,
  tern_defaults = tern_default_labels
) {
  checkmate::assert_character(stats, min.len = 1)

  # Modification:
  # If any label_attr_from_stats is available and valid, save in labels_in
  # if not specified there already (so don't overwrite labels_in).
  if (!is.null(label_attr_from_stats)) {
    valid_label_attr_from_stats <- label_attr_from_stats[
      nzchar(label_attr_from_stats) &
        !sapply(label_attr_from_stats, is.null) &
        !is.na(label_attr_from_stats)
    ]
    if (length(valid_label_attr_from_stats)) {
      do_save <- setdiff(
        names(valid_label_attr_from_stats),
        names(labels_in)
      )
      labels_in <- c(labels_in, valid_label_attr_from_stats[do_save])
    }
  }

  # It may be a list
  if (checkmate::test_list(labels_in, null.ok = TRUE)) {
    checkmate::assert_list(labels_in, null.ok = TRUE)
    # Or it may be a vector of characters
  } else {
    checkmate::assert_character(labels_in, null.ok = TRUE)
  }
  checkmate::assert_list(levels_per_stats, null.ok = TRUE)

  # If unnamed labels given as labels_in and same number of stats, use one label per stat
  if (
    !is.null(labels_in) &&
      length(labels_in) == length(stats) &&
      is.null(names(labels_in)) &&
      is.null(levels_per_stats)
  ) {
    out <- as.list(labels_in) |> stats::setNames(stats)
    return(out)
  }

  # If levels_per_stats not given, assume one row per statistic
  if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) |> stats::setNames(stats)

  # Apply custom labels
  out <- .fill_in_vals_by_stats(levels_per_stats, labels_in, tern_defaults)
  out
}

# Function to loop over each stat and levels to set correct values
.fill_in_vals_by_stats <- function(levels_per_stats, user_in, tern_defaults) {
  out <- list()

  for (stat_i in names(levels_per_stats)) {
    # Get all levels of the statistic
    all_lvls <- levels_per_stats[[stat_i]]

    if ((length(all_lvls) == 1 && all_lvls == stat_i) || is.null(all_lvls)) {
      # One row per statistic
      out[[stat_i]] <- if (stat_i %in% names(user_in)) {
        # 1. Check for stat_i in user input
        user_in[[stat_i]]
      } else if (stat_i %in% names(tern_defaults)) {
        # 2. Check for stat_i in tern defaults
        tern_defaults[[stat_i]]
      } else {
        # 3. Otherwise stat_i
        stat_i
      }
    } else {
      # One row per combination of variable level and statistic
      # Loop over levels for each statistic
      for (lev_i in all_lvls) {
        # Construct row name (stat_i.lev_i)
        row_nm <- paste(stat_i, lev_i, sep = ".")

        out[[row_nm]] <- if (row_nm %in% names(user_in)) {
          # 1. Check for stat_i.lev_i in user input
          user_in[[row_nm]]
        } else if (lev_i %in% names(user_in)) {
          # 2. Check for lev_i in user input
          user_in[[lev_i]]
        } else if (stat_i %in% names(user_in)) {
          # 3. Check for stat_i in user input
          user_in[[stat_i]]
        } else if (lev_i %in% names(tern_defaults)) {
          # 4. Check for lev_i in tern defaults (only used for labels)
          tern_defaults[[lev_i]]
        } else if (stat_i %in% names(tern_defaults)) {
          # 5. Check for stat_i in tern defaults
          tern_defaults[[stat_i]]
        } else {
          # 6. Otherwise lev_i
          lev_i
        }
      }
    }
  }

  out
}

#' @describeIn tern_default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.
#' @keywords internal
tern_get_indents_from_stats <- function(stats,
                                        indents_in = NULL,
                                        levels_per_stats = NULL,
                                        tern_defaults = as.list(rep(0L, length(stats))) |> stats::setNames(stats)) {
  checkmate::assert_character(stats, min.len = 1)
  # It may be a list
  if (checkmate::test_list(indents_in, null.ok = TRUE)) {
    checkmate::assert_list(indents_in, null.ok = TRUE)
    # Or it may be a vector of integers
  } else {
    checkmate::assert_integerish(indents_in, null.ok = TRUE)
  }
  checkmate::assert_list(levels_per_stats, null.ok = TRUE)

  # If levels_per_stats not given, assume one row per statistic
  if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) |> stats::setNames(stats)

  # Single indentation level for all rows
  if (is.null(names(indents_in)) && length(indents_in) == 1) {
    out <- rep(indents_in, length(levels_per_stats |> unlist()))
    return(out)
  }

  # Apply custom indentation
  out <- .fill_in_vals_by_stats(levels_per_stats, indents_in, tern_defaults)
  out
}

# tern_default_labels ----

#' @describeIn tern_default_stats_formats_labels Named `character` vector of default labels for `tern`.
#'   This is only copied here from the latest GitHub version, because otherwise a tern test fails.
#'
#' @keywords internal
tern_default_labels <- c(
  cv = "CV (%)",
  iqr = "IQR",
  geom_cv = "CV % Geometric Mean",
  geom_mean = "Geometric Mean",
  geom_mean_sd = "Geometric Mean (SD)",
  geom_mean_ci = "Geometric Mean 95% CI",
  geom_mean_ci_3d = "Geometric Mean (95% CI)",
  geom_sd = "Geometric SD",
  mad = "Median Absolute Deviation",
  max = "Maximum",
  mean = "Mean",
  mean_ci = "Mean 95% CI",
  mean_ci_3d = "Mean (95% CI)",
  mean_pval = "Mean p-value (H0: mean = 0)",
  mean_sd = "Mean (SD)",
  mean_sdi = "Mean -/+ 1xSD",
  mean_se = "Mean (SE)",
  mean_sei = "Mean -/+ 1xSE",
  median = "Median",
  median_ci = "Median 95% CI",
  median_ci_3d = "Median (95% CI)",
  median_range = "Median (Min - Max)",
  min = "Minimum",
  n = "n",
  n_blq = "n_blq",
  nonunique = "Number of events",
  pval = "p-value (t-test)", # Default for numeric
  pval_counts = "p-value (chi-squared test)", # Default for counts
  quantiles = "25% and 75%-ile",
  quantiles_lower = "25%-ile (95% CI)",
  quantiles_upper = "75%-ile (95% CI)",
  range = "Min - Max",
  range_censor = "Range (censored)",
  range_event = "Range (event)",
  rate = "Adjusted Rate",
  rate_ratio = "Adjusted Rate Ratio",
  sd = "SD",
  se = "SE",
  sum = "Sum",
  unique = "Number of patients with at least one event"
)

#' @name a_freq_j
#'
#' @title Analysis/statistical function for count and percentage in core columns
#' + (optional) relative risk columns
#'
#' @inheritParams proposal_argument_convention

#' @param val (`character` or NULL)\cr
#' When NULL, all levels of the incoming variable (variable used in the `analyze` call)
#' will be considered.\cr
#' When a single `string`, only that current level/value of the incoming variable
#' will be considered.\cr
#' When multiple levels, only those levels/values of the incoming variable
#' will be considered.\cr
#' When no values are observed (eg zero row input df),
#' a row with row-label `No data reported` will be included in the table.
#' @param drop_levels (`logical`)\cr If `TRUE` non-observed levels
#' (based upon .df_row) will not be included.\cr
#' Cannot be used together with `val`.
#' @param excl_levels (`character` or NULL)\cr
#' When NULL, no levels of the incoming variable (variable used in the `analyze` call)
#' will be excluded.\cr
#' When multiple levels, those levels/values of the incoming variable
#' will be excluded.\cr
#' Cannot be used together with `val`.
#' @param new_levels (list(2) or NULL)\cr List of length 2.\cr
#'     First element : names of the new levels\cr
#'     Second element: list with values of the new levels.\cr
#' @param new_levels_after (`logical`)\cr If `TRUE` new levels will be added after last level.
#' @param denom (`string`)\cr
#' One of \cr
#' \itemize{
#' \item \strong{N_col} Column count, \cr
#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
#' \item \strong{N_colgroup} Number of patients from the column group variable
#' (note that this is based upon the input .alt_df_full dataframe).\cr
#' Note that the argument `colgroup` (column variable) needs to be provided,
#' as it cannot be retrieved directly from the column layout definition.
#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
#' (`.row_df` from the rtables splitting machinery).\cr
#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
#' This higher row-level split is specified in the argument `denom_by`.\cr
#' }
#'
#' @param alt_df (`dataframe`)\cr Will be derived based upon alt_df_full and denom_by within a_freq_j.
#' @param parent_df (`dataframe`)\cr Will be derived within a_freq_j based
#' upon the input dataframe that goes into build_table (df) and denom_by.\cr
#' It is a data frame in the higher row-space than the current input df
#' (which underwent row-splitting by the rtables splitting machinery).
#'
#' @param countsource Either `df` or `alt_df`.\cr
#' When `alt_df` the counts will be based upon the alternative dataframe `alt_df`.\cr
#' This is useful for subgroup processing,
#' to present counts of subjects in a subgroup from the alternative dataframe.
#'
#'
#'
#' @return
#' * `s_freq_j`: returns a list of following statistics\cr
#' \itemize{
#' \item n_df
#' \item n_rowdf
#' \item n_parentdf
#' \item n_altdf
#' \item denom
#' \item count
#' \item count_unique
#' \item count_unique_fraction
#' \item count_unique_denom_fraction
#' }
#'
#' @export

#' @importFrom stats setNames
s_freq_j <- function(
    df,
    .var,
    .df_row,
    val = NULL,
    drop_levels = FALSE,
    excl_levels = NULL,
    alt_df,
    parent_df,
    id = "USUBJID",
    denom = c("n_df", "n_altdf", "N_col", "n_rowdf", "n_parentdf"),
    .N_col,
    countsource = c("df", "altdf")) {
  if (is.na(.var) || is.null(.var)) {
    stop("Argument .var cannot be NA or NULL.")
  }

  countsource <- match.arg(countsource)

  if (countsource == "altdf") {
    df <- alt_df
  }

  .alt_df <- alt_df

  n1 <- length(unique(.alt_df[[id]]))
  n2 <- length(unique(df[[id]]))

  n3 <- length(unique(.df_row[[id]]))

  if (is.null(parent_df)) {
    parent_df <- df
  }
  n4 <- length(unique(parent_df[[id]]))


  denom <- match.arg(denom) |> switch(
    "n_altdf" = n1,
    "n_df" = n2,
    "n_rowdf" = n3,
    "N_col" = .N_col,
    "n_parentdf" = n4
  )

  y <- list()

  y$n_altdf <- c("n_altdf" = n1)
  y$n_df <- c("n_df" = n2)
  y$n_rowdf <- c("n_rowdf" = n3)
  y$n_parentdf <- c("n_parentdf" = n4)
  y$denom <- c("denom" = denom)

  if (drop_levels) {
    obs_levs <- unique(.df_row[[.var]])
    obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)

    if (!is.null(excl_levels)) obs_levs <- setdiff(obs_levs, excl_levels)

    if (!is.null(val)) {
      stop("argument val cannot be used together with drop_levels = TRUE.")
    }
    val <- obs_levs
  }

  if (!is.null(val)) {
    df <- df[df[[.var]] %in% val, ]
    .df_row <- .df_row[.df_row[[.var]] %in% val, ]

    df <- h_update_factor(df, .var, val)
    .df_row <- h_update_factor(.df_row, .var, val)
  }

  if (!is.null(excl_levels) && drop_levels == FALSE) {
    # restrict the levels to the ones specified in val argument
    df <- df[!(df[[.var]] %in% excl_levels), ]
    .df_row <- .df_row[!(.df_row[[.var]] %in% excl_levels), ]

    df <- h_update_factor(df, .var, excl_levels = excl_levels)
    .df_row <- h_update_factor(.df_row, .var, excl_levels = excl_levels)
  }

  x <- df[[.var]]
  x_unique <- unique(df[, c(.var, id)])[[.var]]

  if (identical(levels(df[[.var]]), no_data_to_report_str)) {
    xy <- list()
    nms <- c(
      "count",
      "count_unique",
      "count_unique_fraction",
      "count_unique_denom_fraction"
    )
    xy <- replicate(length(nms), list(setNames(list(NULL), no_data_to_report_str)))
    names(xy) <- nms
    y <- append(y, xy)
  } else {
    y$count <- lapply(
      as.list(table(x, useNA = "ifany")),
      stats::setNames,
      nm = "count"
    )

    y$count_unique <- lapply(
      as.list(table(x_unique, useNA = "ifany")),
      stats::setNames,
      nm = "count_unique"
    )

    y$count_unique_fraction <- lapply(
      y$count_unique,
      function(x) {
        ## we want to return - when denom = 0
        ## this is built into formatting function, when fraction is NA
        c(x, "p" = ifelse(denom > 0, x / denom, NA))
      }
    )

    y$count_unique_denom_fraction <- lapply(
      y$count_unique,
      function(x) {
        ## we want to return - when denom = 0
        ## this is built into formatting function, when fraction is NA
        c(x, "d" = denom, "p" = ifelse(denom > 0, x / denom, NA))
      }
    )
  }

  return(y)
}

s_rel_risk_levii_j <- function(
    levii,
    df,
    .var,
    ref_df,
    ref_denom_df,
    .in_ref_col,
    curgrp_denom_df,
    id,
    variables,
    conf_level,
    method,
    weights_method) {
  dfii <- df[df[[.var]] == levii & !is.na(df[[.var]]), ]
  ref_dfii <- ref_df[ref_df[[.var]] == levii & !is.na(ref_df[[.var]]), ]

  # construction of df_val, based upon curgrp_denom_df, dfii
  df_val <- curgrp_denom_df
  df_val$rsp <- FALSE
  # subjects with value levii observed in df TRUE
  df_val$rsp[df_val[[id]] %in% unique(dfii[[id]])] <- TRUE

  # repeat for ref group, based upon ref_denom_df, ref_dfii
  ref_df_val <- ref_denom_df
  ref_df_val$rsp <- FALSE
  # subjects with value levii observed in ref_df TRUE
  ref_df_val$rsp[ref_df_val[[id]] %in% unique(ref_dfii[[id]])] <- TRUE

  ### once 3-d version of diff_ci is available in tern::s_proportion_diff
  ### we should call tern::s_proportion_diff directly
  res_ci_3d <- s_proportion_diff_j(
    df_val,
    .var = "rsp",
    .ref_group = ref_df_val,
    .in_ref_col,
    variables = variables,
    conf_level = conf_level,
    method = method,
    weights_method = weights_method
  )$diff_est_ci
}


s_rel_risk_val_j <- function(
    df,
    .var,
    .df_row,
    ctrl_grp,
    cur_trt_grp,
    trt_var,
    val = NULL,
    drop_levels = FALSE,
    excl_levels = NULL,
    denom_df,
    id = "USUBJID",
    riskdiff = TRUE,
    variables = list(strata = NULL),
    conf_level = 0.95,
    method = c(
      "waldcc",
      "wald",
      "cmh",
      "ha",
      "newcombe",
      "newcombecc",
      "strat_newcombe",
      "strat_newcombecc"
    ),
    weights_method = "cmh") {
  if (drop_levels) {
    obs_levs <- unique(.df_row[[.var]])
    obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)

    if (!is.null(excl_levels)) obs_levs <- setdiff(obs_levs, excl_levels)

    if (!is.null(val)) {
      stop("argument val cannot be used together with drop_levels = TRUE, please specify one or the other.")
    }
    val <- obs_levs
  }

  if (!is.null(val)) {
    # restrict the levels to the ones specified in val argument
    df <- df[df[[.var]] %in% val, ]
    .df_row <- .df_row[.df_row[[.var]] %in% val, ]

    df <- h_update_factor(df, .var, val)
    .df_row <- h_update_factor(.df_row, .var, val)
  }

  if (!is.null(excl_levels) && drop_levels == FALSE) {
    # restrict the levels to the ones specified in val argument
    df <- df[!(df[[.var]] %in% excl_levels), ]
    .df_row <- .df_row[!(.df_row[[.var]] %in% excl_levels), ]

    df <- h_update_factor(df, .var, excl_levels = excl_levels)
    .df_row <- h_update_factor(.df_row, .var, excl_levels = excl_levels)
  }

  levs <- levels(df[[.var]])

  if (identical(levs, no_data_to_report_str)) {
    riskdiff <- FALSE
  }
  if (!riskdiff) {
    return(list(rr_ci_3d = setNames(replicate(length(levs), list(NULL)), levs)))
  }
  ### check on denom_df
  if (NROW(denom_df[[id]]) > length(unique(denom_df[[id]]))) {
    stop(
      "\nProblem: a_freq_j \n
           Denominator has multiple records per id. \n
           Please specify colgroup and/or denom_by to refine your denominator for proper relative risk derivation."
    )
  }

  ### are we in reference column?
  .in_ref_col <- (cur_trt_grp == ctrl_grp)

  ### data from reference group - df based
  ref_df <- get_ctrl_subset(.df_row, trt_var = trt_var, ctrl_grp = ctrl_grp)

  ### denominator data from reference group - denom_df based
  ref_denom_df <- get_ctrl_subset(
    denom_df,
    trt_var = trt_var,
    ctrl_grp = ctrl_grp
  )

  # ensure this is unique record per subject
  ref_denom_df <- unique(ref_denom_df[, c(id, variables$strata), drop = FALSE])

  ### denominator data from current group - denom_df based ---
  curgrp_denom_df <- get_ctrl_subset(
    denom_df,
    trt_var = trt_var,
    ctrl_grp = cur_trt_grp
  )

  # ensure this is unique record per subject
  curgrp_denom_df <- unique(curgrp_denom_df[, c(id, variables$strata), drop = FALSE])

  # calculate the stats for each of the levels in levs
  rr_ci_3d <- sapply(
    levs,
    s_rel_risk_levii_j,
    df = df,
    .var = .var,
    ref_df = ref_df,
    ref_denom_df = ref_denom_df,
    .in_ref_col = .in_ref_col,
    curgrp_denom_df = curgrp_denom_df,
    id = id,
    variables = variables,
    conf_level = conf_level,
    method = method,
    weights_method = weights_method,
    USE.NAMES = TRUE,
    simplify = FALSE
  )
  list(rr_ci_3d = rr_ci_3d)
}


#' @name a_freq_j
#'
#'
#' @inheritParams proposal_argument_convention
#' @param .stats (`character`)\cr statistics to select for the table.
#' See Value for list of available statistics.
#'
#' @param riskdiff (`logical`)\cr
#' When `TRUE`, risk difference calculations will be performed and
#' presented (if required risk difference column splits are included).\cr
#' When `FALSE`, risk difference columns will remain blank
#' (if required risk difference column splits are included).
#' @param ref_path (`string`)\cr Column path specifications for
#' the control group for the relative risk derivation.
#' @param variables Will be passed onto the relative risk function
#' (internal function s_rel_risk_val_j), which is based upon [tern::s_proportion_diff()].\cr
#' See `?tern::s_proportion_diff` for details.
#' @param method Will be passed onto the relative risk function (internal function s_rel_risk_val_j).\cr
#' @param weights_method Will be passed onto the relative risk function (internal function s_rel_risk_val_j).\cr
#' @param label (`string`)\cr
#' When `val`is a single `string`,
#' the row label to be shown on the output can be specified using this argument.\cr
#' When `val` is a `character vector`, the `label_map` argument can be specified
#' to control the row-labels.
#'
#' @param labelstr An argument to ensure this function can be used
#' as a `cfun` in a `summarize_row_groups` call.\cr
#' It is recommended not to utilize this argument for other purposes.\cr
#' The label argument could be used instead (if `val` is a single string)\cr
#' An another approach could be to utilize the `label_map` argument
#' to control the row labels of the incoming analysis variable.
#'
#'
#' @param label_fstr (`string`)\cr
#' a sprintf style format string.
#' It can contain up to one "\%s" which takes the current split value and
#' generates the row/column label.\cr
#' It will be combined with the `labelstr` argument,
#' when utilizing this function as
#' a `cfun` in a `summarize_row_groups` call.\cr
#' It is recommended not to utilize this argument for other purposes.
#' The label argument could be used instead (if `val` is a single string)\cr
#'
#' @param label_map (`tibble`)\cr
#' A mapping tibble to translate levels from the incoming variable into
#' a different row label to be presented on the table.\cr

#'
#' @param .alt_df_full (`dataframe`)\cr Denominator dataset
#' for fraction and relative risk calculations.\cr
#' .alt_df_full is a crucial parameter for the relative risk calculations
#' if this parameter is not set to utilize `alt_counts_df`,
#' then the values in the relative risk columns might not be correct.\cr
#' Once the rtables PR is integrated, this argument gets populated by the rtables
#' split machinery (see [rtables::additional_fun_params]).
#'
#' @param denom_by (`character`)\cr Variables from row-split
#' to be used in the denominator derivation.\cr
#' This controls both `denom = "n_parentdf"` and `denom = "n_altdf"`.\cr
#' When `denom = "n_altdf"`, the denominator is derived from `.alt_df_full`
#' in combination with `denom_by` argument
#' @param .labels_n (named `character`)\cr
#' String to control row labels for the 'n'-statistics.\cr
#' Only useful when more than one 'n'-statistic is requested (rare situations only).
#' @param .formats (named 'character' or 'list')\cr
#' formats for the statistics.
#' @param extrablankline (`logical`)\cr
#' When `TRUE`, an extra blank line will be added after the last value.\cr
#' Avoid using this in template scripts, use section_div = " " instead (once PR for rtables is available)\cr
#' @param extrablanklineafter (`string`)\cr
#' When the row-label matches the string, an extra blank line will be added after
#' that value.
#' @param restr_columns `character`\cr
#' If not NULL, columns not defined in `restr_columns` will be blanked out.
#' @param colgroup The name of the column group variable that is used as source
#' for denominator calculation.\cr
#' Required to be specified when `denom = "N_colgroup"`.
#'
#' @param addstr2levs string, if not NULL will be appended to the rowlabel for that level,
#' eg to add ",n (percent)" at the end of the rowlabels
#'
#' @examples
#' library(dplyr)
#'
#' adsl <- ex_adsl |> select("USUBJID", "SEX", "ARM")
#' adae <- ex_adae |> select("USUBJID", "AEBODSYS", "AEDECOD")
#' adae[["TRTEMFL"]] <- "Y"
#'
#' trtvar <- "ARM"
#' ctrl_grp <- "B: Placebo"
#' adsl$colspan_trt <- factor(ifelse(adsl[[trtvar]] == ctrl_grp, " ", "Active Study Agent"),
#'   levels = c("Active Study Agent", " ")
#' )
#'
#' adsl$rrisk_header <- "Risk Difference (%) (95% CI)"
#' adsl$rrisk_label <- paste(adsl[[trtvar]], paste("vs", ctrl_grp))
#'
#' # join data together
#' adae <- adae |> left_join(adsl)
#'
#' colspan_trt_map <- create_colspan_map(adsl,
#'   non_active_grp = "B: Placebo",
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = trtvar
#' )
#'
#' ref_path <- c("colspan_trt", " ", trtvar, ctrl_grp)
#'
#' lyt <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar, labels_var = "rrisk_label", split_fun = remove_split_levels(ctrl_grp))
#'
#' lyt1 <- lyt |>
#'   analyze("TRTEMFL",
#'     show_labels = "hidden",
#'     afun = a_freq_j,
#'     extra_args = list(
#'       method = "wald",
#'       .stats = c("count_unique_denom_fraction"),
#'       ref_path = ref_path
#'     )
#'   )
#'
#' result1 <- build_table(lyt1, adae, alt_counts_df = adsl)
#'
#' result1
#'
#' # quick check for risk difference results using tern function stat_propdiff_ci
#' # For Drug X vs Placebo
#' x_drug_x <- list(length(unique(subset(adae, adae[[trtvar]] == "A: Drug X")[["USUBJID"]])))
#' N_x_drug_x <- length(unique(subset(adsl, adsl[[trtvar]] == "A: Drug X")[["USUBJID"]]))
#' y_placebo <- list(length(unique(subset(adae, adae[[trtvar]] == ctrl_grp)[["USUBJID"]])))
#' N_y_placebo <- length(unique(subset(adsl, adsl[[trtvar]] == ctrl_grp)[["USUBJID"]]))
#'
#' tern::stat_propdiff_ci(
#'   x = x_drug_x,
#'   N_x = N_x_drug_x,
#'   y = y_placebo,
#'   N_y = N_y_placebo
#' )
#'
#' # For Combination vs Placebo
#' x_combo <- list(length(unique(subset(adae, adae[[trtvar]] == "C: Combination")[["USUBJID"]])))
#' N_x_combo <- length(unique(subset(adsl, adsl[[trtvar]] == "C: Combination")[["USUBJID"]]))
#'
#' tern::stat_propdiff_ci(
#'   x = x_combo,
#'   N_x = N_x_combo,
#'   y = y_placebo,
#'   N_y = N_y_placebo
#' )
#'
#'
#' # example for subgroup AE table
#'
#' extra_args_rr <- list(
#'   denom = "n_altdf",
#'   denom_by = "SEX",
#'   riskdiff = FALSE,
#'   .stats = c("count_unique")
#' )
#'
#' extra_args_rr2 <- list(
#'   denom = "n_altdf",
#'   denom_by = "SEX",
#'   riskdiff = TRUE,
#'   ref_path = ref_path,
#'   method = "wald",
#'   .stats = c("count_unique_denom_fraction"),
#'   na_str = rep("NA", 3)
#' )
#'
#' lyt2 <- basic_table(
#'   top_level_section_div = " ",
#'   colcount_format = "N=xx"
#' ) |>
#'   ## main columns
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar, show_colcounts = TRUE) |>
#'   ## risk diff columns, note nested = FALSE
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar,
#'     labels_var = "rrisk_label", split_fun = remove_split_levels("B: Placebo"),
#'     show_colcounts = FALSE
#'   ) |>
#'   split_rows_by("SEX", split_fun = drop_split_levels) |>
#'   summarize_row_groups("SEX",
#'     cfun = a_freq_j,
#'     extra_args = append(extra_args_rr, list(label_fstr = "Gender: %s"))
#'   ) |>
#'   split_rows_by("TRTEMFL",
#'     split_fun = keep_split_levels("Y"),
#'     indent_mod = -1L,
#'     section_div = c(" ")
#'   ) |>
#'   summarize_row_groups("TRTEMFL",
#'     cfun = a_freq_j,
#'     extra_args = append(extra_args_rr2, list(
#'       label =
#'         "Subjects with >=1 AE", extrablankline = TRUE
#'     ))
#'   ) |>
#'   split_rows_by("AEBODSYS",
#'     split_label = "System Organ Class",
#'     split_fun = trim_levels_in_group("AEDECOD"),
#'     label_pos = "topleft",
#'     section_div = c(" "),
#'     nested = TRUE
#'   ) |>
#'   summarize_row_groups("AEBODSYS",
#'     cfun = a_freq_j,
#'     extra_args = extra_args_rr2
#'   ) |>
#'   analyze("AEDECOD",
#'     afun = a_freq_j,
#'     extra_args = extra_args_rr2
#'   )
#'
#' result2 <- build_table(lyt2, adae, alt_counts_df = adsl)
#'
#' @return
#' * `a_freq_j`: returns a list of requested statistics with formatted `rtables::CellValue()`.\cr
#' Within the relative risk difference columns, the following stats are blanked out:
#' \itemize{
#' \item any of the n-statistics (n_df, n_altdf, n_parentdf, n_rowdf, denom)
#' \item count
#' \item count_unique
#' }
#' For the others (count_unique_fraction, count_unique_denom_fraction),
#' the statistic is replaced by the relative risk difference + confidence interval.
#' @export
#'
a_freq_j <- function(
    df,
    labelstr = NULL,
    .var = NA,
    val = NULL,
    drop_levels = FALSE,
    excl_levels = NULL,
    new_levels = NULL,
    new_levels_after = FALSE,
    addstr2levs = NULL,
    .df_row,
    .spl_context,
    .N_col,
    id = "USUBJID",
    denom = c("N_col", "n_df", "n_altdf", "N_colgroup", "n_rowdf", "n_parentdf"),
    riskdiff = TRUE,
    ref_path = NULL,
    variables = list(strata = NULL),
    conf_level = 0.95,
    method = c(
      "wald",
      "waldcc",
      "cmh",
      "ha",
      "newcombe",
      "newcombecc",
      "strat_newcombe",
      "strat_newcombecc"
    ),
    weights_method = "cmh",
    label = NULL,
    label_fstr = NULL,
    label_map = NULL,
    .alt_df_full = NULL,
    denom_by = NULL,
    .stats = c("count_unique_denom_fraction"),
    .formats = NULL,
    .indent_mods = NULL,
    na_str = rep("NA", 3),
    .labels_n = NULL,
    extrablankline = FALSE,
    extrablanklineafter = NULL,
    restr_columns = NULL,
    colgroup = NULL,
    countsource = c("df", "altdf")) {
  denom <- match.arg(denom)
  method <- match.arg(method)

  if (!is.null(labelstr) && is.na(.var)) {
    stop(
      "Please specify var call to summarize_row_groups when using cfun = a_freq_j, i.e.,\n",
      "summarize_row_groups('varname', cfun = a_freq_j)"
    )
  }

  if (denom == "N_colgroup") {
    if (is.null(colgroup)) {
      stop("Colgroup must be specified when denom = N_colgroup.")
    }

    checkmate::assert_character(colgroup, null.ok = FALSE, max.len = 1)

    if (colgroup == tail(.spl_context$cur_col_split[[1]], 1)) {
      stop(
        "N_colgroup cannot be used when colgroup is lowest column split."
      )
    }
  }

  if (denom %in% c("n_altdf", "N_colgroup") && is.null(.alt_df_full)) {
    stop(".alt_df_full cannot be NULL when denom = n_altdf or N_colgroup.")
  }

  res_dataprep <- h_a_freq_dataprep(
    df = df,
    labelstr = labelstr,
    .var = .var,
    val = val,
    drop_levels = drop_levels,
    excl_levels = excl_levels,
    new_levels = new_levels,
    new_levels_after = new_levels_after,
    addstr2levs = addstr2levs,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .N_col = .N_col,
    id = id,
    denom = denom,
    variables = variables,
    label = label,
    label_fstr = label_fstr,
    label_map = label_map,
    .alt_df_full = .alt_df_full,
    denom_by = denom_by,
    .stats = .stats
  )
  # res_dataprep is list with elements
  # df .df_row val
  # drop_levels excl_levels
  # alt_df parentdf new_denomdf
  # .stats
  # make these elements available in current environment
  df <- res_dataprep$df
  .df_row <- res_dataprep$.df_row
  val <- res_dataprep$val
  drop_levels <- res_dataprep$drop_levels
  excl_levels <- res_dataprep$excl_levels
  alt_df <- res_dataprep$alt_df
  parentdf <- res_dataprep$parentdf
  new_denomdf <- res_dataprep$new_denomdf
  .stats <- .stats

  ## prepare for column based split
  col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (!is.null(colgroup)) {
    colexpr_substr <- h_colexpr_substr(colgroup, .spl_context$cur_col_expr[[1]])

    if (is.null(colexpr_substr)) {
      stop("\n Problem a_freq_j: incorrect colgroup specification.")
    }

    new_denomdf <- subset(.alt_df_full, eval(parse(text = colexpr_substr)))
    .df_row <- subset(.df_row, eval(parse(text = colexpr_substr)))
  }

  if (!inriskdiffcol) {
    if (denom != "N_colgroup" && !is.null(new_denomdf)) {
      ### for this part : perform column split on denominator dataset
      new_denomdf <- subset(new_denomdf, eval(col_expr))
    }
    if (denom == "N_colgroup") {
      denom <- "n_altdf"
    }

    x_stats <- s_freq_j(
      df,
      .var = .var,
      .df_row = .df_row,
      val = val,
      drop_levels = drop_levels,
      excl_levels = excl_levels,
      alt_df = new_denomdf,
      parent_df = new_denomdf,
      id = id,
      denom = denom,
      .N_col = .N_col,
      countsource = countsource
    )
    ## remove relrisk stat from .stats
    .stats_adj <- .stats[!(.stats %in% "rr_ci_3d")]
  } else {
    if (riskdiff && is.null(ref_path)) {
      stop("argument ref_path cannot be NULL.")
    }
    ### denom N_colgroup should not be used in layout with risk diff columns
    if (denom == "N_colgroup") {
      stop(
        "denom N_colgroup cannot be used in a layout with risk diff columns."
      )
    }
    if (!riskdiff) {
      trt_var <- NULL
      ctrl_grp <- NULL
      cur_trt_grp <- NULL
    }

    if (riskdiff) {
      trt_var_refpath <- h_get_trtvar_refpath(
        ref_path,
        .spl_context,
        df
      )
      # trt_var_refpath is list with elements
      # trt_var trt_var_refspec cur_trt_grp ctrl_grp
      # make these elements available in current environment
      trt_var <- trt_var_refpath$trt_var
      trt_var_refspec <- trt_var_refpath$trt_var_refspec
      cur_trt_grp <- trt_var_refpath$cur_trt_grp
      ctrl_grp <- trt_var_refpath$ctrl_grp

      if (!is.null(colgroup) && trt_var == colgroup) {
        stop(
          "\n Problem: a_freq_j: colgroup and treatment variable from ref_path are the same.
             This is not intented for usage with relative risk columns.
             Either remove risk difference columns from layout, set riskdiff = FALSE, or update colgroup."
        )
      }
    }

    x_stats <- s_rel_risk_val_j(
      df,
      .var = .var,
      .df_row = .df_row,
      val = val,
      drop_levels = drop_levels,
      excl_levels = excl_levels,
      denom_df = new_denomdf,
      id = id,
      riskdiff = riskdiff,
      # treatment/ref group related arguments
      trt_var = trt_var,
      ctrl_grp = ctrl_grp,
      cur_trt_grp = cur_trt_grp,
      # relrisk specific arguments
      variables = variables,
      conf_level = conf_level,
      method = method,
      weights_method = weights_method
    )

    ## this will ensure the following stats will be shown as empty column in relative risk column
    xy <- sapply(
      c(
        "count",
        "count_unique",
        "n_df",
        "n_altdf",
        "n_rowdf",
        "n_parentdf",
        "denom"
      ),
      function(x) {
        stats::setNames(list(x = NULL), x)
      },
      USE.NAMES = TRUE,
      simplify = FALSE
    )
    x_stats <- append(x_stats, xy)

    ## restrict to relrisk stat from .stats
    # when both count_unique_fraction and count_unique_denom_fraction are requested, the rr_ci_3d stat is in here twice
    # this does not seem to introduce a problem, although might not be ideal
    # see further
    .stats_adj <- replace(
      .stats,
      .stats %in%
        c(
          "count_unique_fraction",
          "count_unique_denom_fraction",
          "fraction_count_unique_denom"
        ),
      "rr_ci_3d"
    )
  }

  res_prepinrows <- h_a_freq_prepinrows(
    x_stats,
    .stats_adj,
    .formats,
    labelstr,
    label_fstr,
    label,
    .indent_mods,
    .labels_n,
    na_str
  )
  # res_prepinrows is list with elements
  # x_stats .formats .labels .indent_mods .format_na_strs
  # make these elements available in current environment
  x_stats <- res_prepinrows$x_stats
  .formats <- res_prepinrows$.formats
  .labels <- res_prepinrows$.labels
  .indent_mods <- res_prepinrows$.indent_mods
  .format_na_strs <- res_prepinrows$.format_na_strs

  ### blank out columns not in restr_columns
  # get column label
  colid_lbl <- utils::tail(
    .spl_context$cur_col_split_val[[NROW(.spl_context)]],
    1
  )
  if (!is.null(restr_columns) && !(tolower(colid_lbl) %in% tolower(restr_columns))) {
    x_stats <- lapply(x_stats, FUN = function(x) {
      NULL
    })
  }

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )

  ### add extra blankline to the end of inrows --- as long as section_div is not working as expected
  if (!is.null(inrows) && extrablankline ||
        (!is.null(extrablanklineafter) && length(.labels) == 1 && .labels == extrablanklineafter)) {
    inrows <- add_blank_line_rcells(inrows)
  }

  return(inrows)
}

#' Statistical Function for Patient Years
#'
#' This function calculates patient years based on the provided data.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .var (`string`)\cr variable name containing the patient years data.
#' @param id (`string`)\cr subject variable name.
#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
#' @param source (`string`)\cr source of data, either "alt_df" or "df".
#' @param inriskdiffcol (`logical`)\cr flag indicating if the function is called within a risk difference column.
#'
#' @return A list containing the patient years statistics.
#'
#' @keywords internal
s_patyrs_j <- function(
  df,
  .var,
  id = "USUBJID",
  .alt_df_full,
  source = c("alt_df", "df"),
  inriskdiffcol = FALSE
) {
  source <- match.arg(source)

  if (source == "alt_df") {
    if (is.null(.alt_df_full)) {
      stop(paste(
        "s_patyrs_j with source = alt_df requires a non-null .alt_df_full"
      ))
    }
    df <- .alt_df_full
  }
  df <- unique(df[, c(id, .var)])

  x <- list()

  if (!inriskdiffcol) {
    patyrs <- sum(df[[.var]])
  } else {
    patyrs <- list(x = NULL)
  }
  x[["patyrs"]] <- stats::setNames(patyrs, nm = "patyrs")

  return(x)
}

#' Calculate Patient Years
#'
#' This function calculates patient years based on the provided data.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .var (`string`)\cr variable name containing the patient years data.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param id (`string`)\cr subject variable name.
#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
#' @param .formats (named 'character' or 'list')\cr formats for the statistics.
#' @param .labels (named 'character')\cr labels for the statistics.
#' @param source (`string`)\cr source of data, either "alt_df" or "df".
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param .stats (`character`)\cr statistics to select for the table.
#'
#' @return A list of in_rows objects containing the patient years statistics.
#'
#' @export
#' @keywords internal
a_patyrs_j <- function(
  df,
  .var,
  .df_row,
  id = "USUBJID",
  .alt_df_full = NULL,
  .formats = NULL,
  .labels = NULL,
  source = c("alt_df", "df"),
  .spl_context,
  .stats = "patyrs"
) {
  source <- match.arg(source)

  if (length(.stats) > 1 || (length(.stats) == 1 && .stats != "patyrs")) {
    stop("a_patyrs_j: .stats must be 'patyrs'.")
  }

  if (source == "alt_df" && is.null(.alt_df_full)) {
    stop(paste(
      "a_patyrs_j: .alt_df_full cannot be NULL when source = 'alt_df'."
    ))
  }

  col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (source == "alt_df") {
    ### derive appropriate alt_df based upon .spl_context and .alt_df_full
    ### note that this is not yet within the current column

    alt_df <- h_create_altdf(
      .spl_context,
      .df_row,
      .alt_df_full,
      denom_by = NULL,
      id = id,
      variables = NULL,
      denom = "n_altdf"
    )
    ## restrict to current column
    new_denomdf <- subset(alt_df, eval(col_expr))
  } else {
    new_denomdf <- df
  }

  x_stats <- s_patyrs_j(
    df,
    .alt_df_full = new_denomdf,
    .var = .var,
    id = id,
    source = source,
    inriskdiffcol = inriskdiffcol
  )

  x_stats <- x_stats[.stats]

  levels_per_stats <- lapply(x_stats, names)

  .formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
  .labels <- junco_get_labels_from_stats(.stats, .labels, levels_per_stats)
  .labels <- .unlist_keep_nulls(.labels)

  x_stats <- x_stats[.stats]

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels
  )

  return(inrows)
}

#' Statistical Function for Exposure-Adjusted Incidence Rate
#'
#' This function calculates exposure-adjusted incidence rates (EAIR) per 100 person-years for a
#' specific level of a variable.
#'
#' @param levii (`string`)\cr the specific level of the variable to calculate EAIR for.
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param .var (`string`)\cr variable name that is passed by `rtables`.
#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
#' @param id (`string`)\cr subject variable name.
#' @param diff (`logical`)\cr if TRUE, risk difference calculations will be performed.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param trt_var (`string`)\cr treatment variable name.
#' @param ctrl_grp (`string`)\cr control group value.
#' @param cur_trt_grp (`string`)\cr current treatment group value.
#' @param inriskdiffcol (`logical`)\cr flag indicating if the function is called within a risk difference column.
#' @param fup_var (`string`)\cr follow-up variable name.
#' @param occ_var (`string`)\cr occurrence variable name.
#' @param occ_dy (`string`)\cr occurrence day variable name.
#'
#' @return A list containing the following statistics:
#' \itemize{
#'   \item n_event: Number of events
#'   \item person_years: Total person-years of follow-up
#'   \item eair: Exposure-adjusted incidence rate per 100 person-years
#'   \item eair_diff: Risk difference in EAIR (if diff=TRUE and inriskdiffcol=TRUE)
#'   \item eair_diff_ci: Confidence interval for the risk difference (if diff=TRUE and inriskdiffcol=TRUE)
#' }
#'
#' @keywords internal
s_eair100_levii_j <- function(
  levii,
  df,
  .df_row,
  .var,
  .alt_df_full = NULL,
  id = "USUBJID",
  diff = FALSE,
  # treatment/ref group related arguments
  conf_level = 0.95,
  trt_var = NULL,
  ctrl_grp = NULL,
  cur_trt_grp = NULL,
  inriskdiffcol = FALSE,
  fup_var,
  occ_var,
  occ_dy
) {
  if (diff && inriskdiffcol) {
    .alt_df_full_cur_group <- get_ctrl_subset(
      .alt_df_full,
      trt_var = trt_var,
      ctrl_grp = cur_trt_grp
    )
  } else {
    ### within a_eair100_j we need to ensure proper dataframe will be passed to .alt_df_full
    .alt_df_full_cur_group <- .alt_df_full
  }
  cur_dfs <- h_get_eair_df(
    levii,
    df,
    denom_df = .alt_df_full_cur_group,
    .var = .var,
    id = id,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy
  )
  cur_df_num <- cur_dfs$df_num
  cur_df_denom <- cur_dfs$df_denom

  ### statistics derivation
  cur_AECOUNT <- length(unique(cur_df_num[[id]]))
  cur_YRSFUP <- sum(cur_df_denom[["mod_fup_var"]])
  cur_eair <- 100 * cur_AECOUNT / cur_YRSFUP

  x <- list()
  x$n_event <- c("n_event" = cur_AECOUNT)
  x$person_years <- c("person_years" = cur_YRSFUP)
  x$eair <- c("eair" = cur_eair)

  if (diff && inriskdiffcol) {
    x$n_event <- c("n_event" = NULL)
    x$person_years <- c("person_years" = NULL)
    x$eair <- c("eair" = NULL)

    alt_df_full_ref_group <- get_ctrl_subset(
      .alt_df_full,
      trt_var = trt_var,
      ctrl_grp = ctrl_grp
    )

    ref_group <- get_ctrl_subset(
      .df_row,
      trt_var = trt_var,
      ctrl_grp = ctrl_grp
    )

    ref_dfs <- h_get_eair_df(
      levii,
      df = ref_group,
      denom_df = alt_df_full_ref_group,
      .var = .var,
      id = id,
      fup_var = fup_var,
      occ_var = occ_var,
      occ_dy = occ_dy
    )

    ref_df_num <- ref_dfs$df_num
    ref_df_denom <- ref_dfs$df_denom

    ### statistics derivation
    ref_AECOUNT <- length(unique(ref_df_num[[id]]))
    ref_YRSFUP <- sum(ref_df_denom[["mod_fup_var"]])
    ref_eair <- 100 * ref_AECOUNT / ref_YRSFUP

    rdiff <- cur_eair - ref_eair

    sd <- sqrt(cur_AECOUNT / cur_YRSFUP^2 + ref_AECOUNT / ref_YRSFUP^2) * 100

    coeff <- stats::qnorm((1 + conf_level) / 2)
    lcl <- rdiff - (coeff * sd)
    ucl <- rdiff + (coeff * sd)

    eair_diff <- c(rdiff, lcl, ucl)

    x$eair_diff <- stats::setNames(
      c("eair_diff" = eair_diff),
      nm = c("estimate", "lcl", "ucl")
    )
  } else {
    x$eair_diff <- c("eair_diff" = NULL)
  }

  return(x)
}

#' Calculate Exposure-Adjusted Incidence Rate per 100 Patient-Years
#'
#' This function calculates the exposure-adjusted incidence rate (EAIR) per 100 patient-years.
#' It can also calculate the difference in EAIR between treatment groups.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param labelstr (`string`)\cr label string for the row.
#' @param .var (`string`)\cr variable name for analysis.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param .alt_df_full (`dataframe`)\cr denominator dataset for calculations.
#' @param id (`string`)\cr subject variable name.
#' @param drop_levels (`logical`)\cr if TRUE, non-observed levels will not be included.
#' @param riskdiff (`logical`)\cr if TRUE, risk difference calculations will be performed.
#' @param ref_path (`string`)\cr column path specifications for the control group.
#' @param .stats (`character`)\cr statistics to select for the table.
#' @param .formats (named 'character' or 'list')\cr formats for the statistics.
#' @param .labels (named 'character')\cr labels for the statistics.
#' @param .indent_mods (named `integer`)\cr indent modifiers for the labels.
#' @param na_str (`string`)\cr string used to replace all NA or empty values in the output.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param fup_var (`string`)\cr variable name for follow-up time.
#' @param occ_var (`string`)\cr variable name for occurrence.
#' @param occ_dy (`string`)\cr variable name for occurrence day.
#'
#' @return A list of in_rows objects containing the EAIR statistics.
#'
#' @export
#' @keywords internal
a_eair100_j <- function(
  df,
  labelstr = NULL,
  .var,
  .df_row,
  .spl_context,
  .alt_df_full = NULL,
  id = "USUBJID",
  drop_levels = FALSE,
  riskdiff = TRUE,
  ref_path = NULL,
  .stats = c("eair"),
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3),
  # treatment/ref group related arguments
  conf_level = 0.95,
  fup_var,
  occ_var,
  occ_dy
) {
  ## prepare for column based split
  col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  # if no stats requested, get all stats
  .stats <- junco_get_stats(
    "a_eair100_j",
    stats_in = .stats,
    custom_stats_in = NULL
  )

  ### combine all preprocessing of incoming df/.df_row in one function
  ### do this outside stats derivation functions (s_freq_j/)
  ### use all of val/excl_levels/drop_levels//new_levels/label/label_map/labelstr/label_fstr
  upd_dfrow <- h_upd_dfrow(
    .df_row,
    .var,
    val = NULL,
    excl_levels = NULL,
    drop_levels = drop_levels,
    new_levels = NULL,
    new_levels_after = FALSE,
    label = NULL,
    label_map = NULL,
    labelstr = labelstr,
    label_fstr = NULL,
    .spl_context = .spl_context
  )

  .df_row <- upd_dfrow$df_row
  df <- upd_dfrow$df

  if (is.null(.alt_df_full)) {
    stop(paste("a_eair100_j: .alt_df_full cannot be NULL."))
  }

  ### derive appropriate alt_df based upon .spl_context and .alt_df_full
  ### note that only row-based splits are done
  ### for now only for variables from the first split_rows_by
  alt_df <- h_create_altdf(
    .spl_context,
    .df_row,
    .alt_df_full,
    denom_by = NULL,
    id = id,
    variables = NULL,
    denom = "n_altdf"
  )
  new_denomdf <- alt_df

  fn_Args <- list(
    df = df,
    .df_row = .df_row,
    .var = .var,
    id = id,
    diff = riskdiff,
    inriskdiffcol = inriskdiffcol,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy
  )

  if (riskdiff && inriskdiffcol) {
    trt_var_refpath <- h_get_trtvar_refpath(
      ref_path,
      .spl_context,
      df
    )
    # trt_var_refpath is list with elements
    # trt_var trt_var_refspec cur_trt_grp ctrl_grp
    # make these elements available in current environment
    trt_var <- trt_var_refpath$trt_var
    trt_var_refspec <- trt_var_refpath$trt_var_refspec
    cur_trt_grp <- trt_var_refpath$cur_trt_grp
    ctrl_grp <- trt_var_refpath$ctrl_grp

    fn_args_x <- list(
      .alt_df_full = .alt_df_full,
      # treatment/ref group related arguments
      conf_level = conf_level,
      trt_var = trt_var,
      ctrl_grp = ctrl_grp,
      cur_trt_grp = cur_trt_grp
    )
  } else {
    new_denomdf <- subset(new_denomdf, eval(col_expr))
    fn_args_x <- list(.alt_df_full = new_denomdf)
  }

  fn_Args <- append(fn_Args, fn_args_x)

  levs <- levels(.df_row[[.var]])
  y <- mapply(
    s_eair100_levii_j,
    levii = levs,
    MoreArgs = fn_Args,
    SIMPLIFY = FALSE
  )

  ### rearrange list y to  list to x_stats
  #### this is to ensure the remainder of the code can stay the same as in a_freq_j
  stnms <- c("eair", "eair_diff", "n_event", "person_years")
  x_stats <- extract_x_stats(y, stnms)

  if (!inriskdiffcol) {
    .stats_adj <- .stats
  } else {
    .stats_adj <- replace(.stats, .stats %in% c("eair"), "eair_diff")
  }

  .stats <- .stats_adj

  # Fill in formatting defaults

  if (length(levs) > 1 && length(.stats) > 1) {
    message(
      "a_eair100_j : with multiple stats and multiple levels of analysis
      variable it is recommended to apply an extra split_rows_by on the analysis variable"
    )
  }

  x_stats <- x_stats[.stats]

  levels_per_stats <- lapply(x_stats, names)

  .formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
  .labels <- junco_get_labels_from_stats(.stats, .labels, levels_per_stats)
  .labels <- .unlist_keep_nulls(.labels)

  .indent_mods <- junco_get_indents_from_stats(
    .stats,
    .indent_mods,
    levels_per_stats
  )
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  # .format_na_strs processing
  # if na_str = c(NA, NA, NA)
  # this will ensure the ci (NA, NA, NA) will be represented as NE (NE, NE)
  # the value NE is defined as the default to replace NA in our jjcs format

  if (!is.null(na_str)) {
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
  } else {
    .format_na_strs <- NULL
  }

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )

  return(inrows)
}

#' Extract Estimates from Multivariate Cox Regression Model Fit Object
#'
#' @param x (`coxreg.multivar`)\cr from [tern::fit_coxreg_multivar()].
#' @export
#' @return A data frame containing Cox regression results with columns for term,
#'   coef_se (coefficient and standard error), p.value, hr (hazard ratio),
#'   hr_ci (confidence interval for hazard ratio), and labels (formatted term labels).
#' @keywords internal
#'
#' @examples
#' anl <- tern::tern_ex_adtte |>
#'   dplyr::mutate(EVENT = 1 - CNSR)
#'
#' variables <- list(
#'   time = 'AVAL',
#'   event = 'EVENT',
#'   arm = 'ARM',
#'   covariates = c('SEX', 'AGE')
#' )
#'
#' control <- tern::control_coxreg(
#'   conf_level = 0.9,
#'   ties = 'efron'
#' )
#'
#' fit <- tern::fit_coxreg_multivar(
#'   data = anl,
#'   variables = variables,
#'   control = control
#' )
#'
#' h_extract_coxreg_multivar(fit)
h_extract_coxreg_multivar <- function(x) {
  checkmate::assert_class(x, "coxreg.multivar")
  vars <- c(x$vars$arm, x$vars$covariates)

  # Extract the table.
  tab <- broom::tidy(x$mod, exponentiate = FALSE, conf.int = TRUE, conf.level = x$control$conf_level)
  tab$hr <- exp(tab$estimate)
  tab$hr_ci <- Map(lcl = exp(tab$conf.low), ucl = exp(tab$conf.high), f = function(lcl, ucl) c(lcl, ucl))
  tab$coef_se <- Map(coef = tab$estimate, se = tab$std.error, f = function(coef, se) c(coef, se))
  colnms <- c("term", "coef_se", "p.value", "hr", "hr_ci")
  tab <- tab[, colnms, drop = FALSE]

  # Format nicely the term labels.
  var_to_term <- sapply(vars, function(v) which(startsWith(tab$term, v)), USE.NAMES = TRUE, simplify = FALSE)
  tab$labels <- unlist(lapply(vars, function(v) {
    inds <- var_to_term[[v]]
    strip_term <- gsub(paste0("^", v), "", tab$term[inds])
    this_df <- x$dat[v]
    if (is.character(this_df[[1]])) {
      this_df[[1]] <- as.factor(this_df[[1]])
    }
    if (is.factor(this_df[[1]])) {
      ref_level <- levels(this_df[[1]])[1]
      var_name <- if (v == x$vars$arm) "Treatment" else labels_or_names(this_df)
      paste0(var_name, " (", strip_term, " vs. ", ref_level, ")")
    } else {
      labels_or_names(this_df)
    }
  }))
  tab
}

#' First Level Column Split Function for TEFOS03 (mmy) Table Layout
#' @seealso [rtables::make_split_fun()] for details.
#' @keywords internal
tefos03_first_post_fun <- function(ret, spl, fulldf, .spl_context) {
  all_expr <- expression(TRUE)
  short_split_result(model_fit = "Model Fit", hazard_ratio = "Hazard Ratio", fulldf = fulldf)
}
tefos03_first_split_fun <- make_split_fun(post = list(tefos03_first_post_fun))

#' Second Level Column Split Function Factory for TEFOS03 (mmy) Table Layout
#'
#' @inheritParams proposal_argument_convention
#'
#' @return Split function to use in the TEFOS03 (mmy) and related table layouts.
#'
#' @seealso [tefos03_first_post_fun()] for the first level split.
#' @keywords internal
tefos03_second_split_fun_fct <- function(conf_level) {
  post_fun <- function(ret, spl, fulldf, .spl_context) {
    all_expr <- expression(TRUE)
    colset <- .spl_context[nrow(.spl_context), "value"][[1]]
    if (colset == "model_fit") {
      short_split_result(coef_se = "Coeff. (SE)", pval = "p-value", fulldf = fulldf)
    } else {
      short_split_result(hr_est = "Estimate", hr_ci = f_conf_level(conf_level), fulldf = fulldf)
    }
  }
  make_split_fun(post = list(post_fun))
}

#' @keywords internal
memoised_fit_coxreg_multivar <- memoise::memoise(fit_coxreg_multivar)

#' Analysis Function for TEFOS03 and Related Table Layouts
#'
#' @inheritParams proposal_argument_convention
#' @param control (`list`)\cr from [tern::control_coxreg()].
#' @param formats (`list`)\cr including `coef_se`, `hr_est`, `hr_ci` and `pval` formats.
#' @param variables (`list`)\cr see [tern::fit_coxreg_multivar()] for required variable
#'   specifications.
#'
#' @keywords internal
tefos03_afun <- function(df, .var, .spl_context, variables, control, formats) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  model_fit <- memoised_fit_coxreg_multivar(data = df, variables = variables, control = control)
  tab <- h_extract_coxreg_multivar(model_fit)
  if (this_col_split[1] == "model_fit") {
    if (this_col_split[2] == "coef_se") {
      in_rows(.list = tab$coef_se, .formats = formats$coef_se, .labels = tab$labels)
    } else {
      in_rows(.list = tab$p.value, .formats = formats$pval, .labels = tab$labels)
    }
  } else {
    if (this_col_split[2] == "hr_est") {
      in_rows(.list = tab$hr, .formats = formats$hr_est, .labels = tab$labels)
    } else {
      in_rows(.list = tab$hr_ci, .formats = formats$hr_ci, .labels = tab$labels)
    }
  }
}

#' Layout Generating Function for TEFOS03 and Related Cox Regression Layouts
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams tefos03_afun
#' @param var (`string`)\cr any variable from the data, because this is not used.
#'
#' @return Modified layout.
#' @export
#' @examples
#' anl <- tern::tern_ex_adtte |>
#'   dplyr::mutate(EVENT = 1 - CNSR)
#'
#' variables <- list(
#'   time = 'AVAL',
#'   event = 'EVENT',
#'   arm = 'ARM',
#'   covariates = c('SEX', 'AGE')
#' )
#'
#' basic_table() |>
#'   summarize_coxreg_multivar(
#'     var = 'STUDYID',
#'     variables = variables
#'   ) |>
#'   build_table(df = anl)
summarize_coxreg_multivar <- function(
  lyt,
  var,
  variables,
  control = control_coxreg(),
  formats = list(
    coef_se = jjcsformat_xx("xx.xx (xx.xx)"),
    hr_est = jjcsformat_xx("xx.xx"),
    hr_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
    pval = jjcsformat_pval_fct(0)
  )
) {
  second_split_fun <- tefos03_second_split_fun_fct(conf_level = control$conf_level)
  lyt |>
    split_cols_by(var = var, split_fun = tefos03_first_split_fun) |>
    split_cols_by(var = var, split_fun = second_split_fun) |>
    analyze(
      vars = var,
      var_labels = "Model Parameter",
      show_labels = "visible",
      afun = tefos03_afun,
      extra_args = list(variables = variables, control = control, formats = formats)
    )
}

#' MMRM Analysis for Imputed Datasets
#'
#' Performs an MMRM for two or more groups returning the estimated
#' 'treatment effect' (i.e. the contrast between treatment groups and the control
#' group) and the least square means estimates in each group.
#'
#' @param data (`data.frame`)\cr containing the data to be used in the model.
#' @param vars (`vars`)\cr list as generated by [set_vars()]. Only the `subjid`, `group`,
#' `visit`, `outcome` and `covariates` elements are required. See details.
#' @param cov_struct (`string`)\cr the covariance structure to use. Note that the same
#'   covariance structure is assumed for all treatment groups.
#' @param visits (`NULL` or `character`)\cr An optional character vector specifying
#'   which visits to fit the MMRM at. If `NULL`, the MMRM model will be fit to
#'   the whole dataset.
#' @param weights (`string`)\cr the weighting strategy to be used when calculating the
#'   least square means, either `'counterfactual'` or `'equal'`.
#' @param ... additional arguments passed to [mmrm::mmrm()], in particular
#'   `method` and `vcov` to control the degrees of freedom and variance-covariance
#'   adjustment methods as well as `reml` decide between REML and ML estimation.
#'
#' @details
#' The function works as follows:
#'
#' 1. Optionally select the subset of the `data` corresponding to `visits.
#' 2. Fit an MMRM as `vars$outcome ~ vars$group + vars$visit + vars$covariates`
#'    with the specified covariance structure for visits within subjects.
#' 3. Extract the 'treatment effect' & least square means for each treatment group
#'    vs the control group.
#'
#' In order to meet the formatting standards set by [analyse()] the results will be collapsed
#' into a single list suffixed by the visit name, e.g.:
#' ```
#' list(
#'    var_B_visit_1 = list(est = ...),
#'    trt_B_visit_1 = list(est = ...),
#'    lsm_A_visit_1 = list(est = ...),
#'    lsm_B_visit_1 = list(est = ...),
#'    var_B_visit_2 = list(est = ...),
#'    trt_B_visit_2 = list(est = ...),
#'    lsm_A_visit_2 = list(est = ...),
#'    lsm_B_visit_2 = list(est = ...),
#'    ...
#' )
#' ```
#' Please note that 'trt' refers to the treatment effects, and 'lsm' refers to the least
#' square mean results. In the above example `vars$group` has two factor levels A and B.
#' The new 'var' refers to the model estimated variance of the residuals at the given
#' visit, together with the degrees of freedom (which is treatment group specific).
#'
#' If you want to include additional interaction terms in your model this can be done
#' by providing them to the `covariates` argument of [set_vars()]
#' e.g. `set_vars(covariates = c('sex*age'))`.
#'
#' @note The `group` and `visit` interaction `group:visit` is not included by
#' default in the model, therefore please add that to `covariates` manually if
#' you want to include it. This will make sense in most cases.
#'
#' @seealso [rbmi_analyse()]
#' @seealso [mmrm::mmrm()]
#' @seealso [set_vars()]
#' @export
rbmi_mmrm <- function(
  data,
  vars,
  cov_struct = c("us", "toep", "cs", "ar1"),
  visits = NULL,
  weights = c("counterfactual", "equal"),
  ...
) {
  subjid <- vars[["subjid"]]
  outcome <- vars[["outcome"]]
  group <- vars[["group"]]
  visit <- vars[["visit"]]
  covariates <- vars[["covariates"]]

  checkmate::assert_string(subjid)
  checkmate::assert_string(outcome)
  checkmate::assert_string(group)
  checkmate::assert_string(visit)
  checkmate::assert_character(covariates, null.ok = TRUE)

  cov_struct <- match.arg(cov_struct)
  weights <- match.arg(weights)

  expected_vars <- c((utils::getFromNamespace("extract_covariates", "rbmi"))(covariates), outcome, group, subjid, visit)
  checkmate::assert_subset(expected_vars, names(data))

  checkmate::assert_factor(data[[visit]])
  if (is.null(visits)) {
    visits <- as.character(unique(data[[visit]]))
  }
  checkmate::assert_subset(visits, as.character(data[[visit]]))
  data <- data[data[[visit]] %in% visits, , drop = FALSE]

  covariates_part <- paste(covariates, collapse = " + ")
  grp_visit_part <- paste(group, "+", visit)
  random_effects_part <- paste0(cov_struct, "(", visit, " | ", subjid, ")")
  rhs_formula <- paste(grp_visit_part, "+", random_effects_part)
  if (covariates_part != "") rhs_formula <- paste(covariates_part, "+", rhs_formula)
  formula <- stats::as.formula(paste(outcome, "~", rhs_formula))

  fit <- mmrm::mmrm(formula, data = data, ...)
  res <- lapply(visits, function(x) {
    res <- rbmi_mmrm_single_info(fit, visit_level = x, visit = visit, group = group, weights = weights)
    names(res) <- paste0(names(res), "_", x)
    return(res)
  })
  unlist(res, recursive = FALSE)
}

#' Extract Single Visit Information from a Fitted MMRM for Multiple Imputation Analysis
#'
#' @description
#' Extracts relevant estimates from a given fitted MMRM. See [rbmi_mmrm()] for full details.
#'
#' @param fit (`mmrm`)\cr the fitted MMRM.
#' @param visit_level (`string`)\cr the visit level to extract information for.
#' @param visit (`string`)\cr the name of the visit variable.
#' @param group (`string`)\cr the name of the group variable.
#'
#' @inheritParams rbmi_mmrm
#' @seealso [rbmi_mmrm()]
rbmi_mmrm_single_info <- function(fit, visit_level, visit, group, weights) {
  checkmate::assert_class(fit, "mmrm")
  checkmate::assert_string(visit_level)
  checkmate::assert_string(visit)
  checkmate::assert_string(group)

  data <- mmrm::component(fit, "full_frame")
  checkmate::assert_factor(data[[group]])
  grp_levels <- levels(data[[group]])

  visit_at_level <- stats::setNames(list(visit_level), visit)
  em_res <- emmeans::emmeans(fit, group, by = visit, at = visit_at_level, weights = weights)
  em_df <- as.data.frame(em_res)

  all_lsm <- lapply(grp_levels, function(x) {
    this_df <- em_df[em_df[[group]] == x, ]
    with(this_df, list(est = emmean, se = SE, df = df))
  })
  names(all_lsm) <- paste0("lsm_", grp_levels)

  var_est <- mmrm::VarCorr(fit)[visit_level, visit_level]

  cont_res <- emmeans::contrast(em_res, "trt.vs.ctrl", ref = grp_levels[1])
  cont_df <- as.data.frame(cont_res)

  all_var <- lapply(grp_levels[-1], function(x) {
    this_df <- cont_df[cont_df[["contrast"]] == paste(x, "-", grp_levels[1]), ]
    # Note: This should be revisited here for the `se` - currently we take the SE from the LS means contrast, not
    # from the variance estimate!
    with(this_df, list(est = var_est, se = SE, df = df))
  })
  names(all_var) <- paste0("var_", grp_levels[-1])

  all_trt <- lapply(grp_levels[-1], function(x) {
    this_df <- cont_df[cont_df[["contrast"]] == paste(x, "-", grp_levels[1]), ]
    with(this_df, list(est = estimate, se = SE, df = df))
  })
  names(all_trt) <- paste0("trt_", grp_levels[-1])

  c(all_var, all_trt, all_lsm)
}

s_summarize_desc_j <- function(df, .var, .ref_group, .in_ref_col, control = control_analyze_vars()) {
  x <- df[[.var]]
  y1 <- s_summary(x)
  y2 <- NULL

  # diff in means versus control group, based upon 2 sample t.test
  y2$mean_diffci <- numeric()
  if (!is.null(.ref_group) && !.in_ref_col) {
    x1 <- df[[.var]]
    x2 <- .ref_group[[.var]]

    x1 <- x1[!is.na(x1)]
    x2 <- x2[!is.na(x2)]

    if ((length(x1) > 1 && length(x2) > 1)) {
      ttest_stat <- stats::t.test(x1, x2, conf.level = control$conf_level)

      stat <- ttest_stat[c("estimate", "conf.int")]
      stat$diff <- stat$estimate[1] - stat$estimate[2]
      stat <- c(stat$diff, stat$conf.int)

      y2$mean_diffci <- with_label(
        c(mean_diffci = stat),
        paste("Difference in Mean + ", f_conf_level(control$conf_level))
      )
    } else {
      y2b <- s_summary(.ref_group[[.var]])
      diff <- y1[["mean"]] - y2b[["mean"]]
      stat <- c(diff, NA, NA)

      y2$mean_diffci <- with_label(
        c(mean_diffci = stat),
        paste("Difference in Mean + ", f_conf_level(control$conf_level))
      )
    }
  }
  y <- c(y1, y2)

  return(y)
}

s_aval_chg_col1 <- function(df, .var, denom, .N_col, id, indatavar) {
  ## First column AVAL - show n/N (%)
  mystat <- "n"

  if (!is.null(indatavar)) {
    df <- subset(df, !is.na(df[[indatavar]]))
  }

  x <- df[[.var]]

  x_stats <- s_summary(x)
  x_stats <- x_stats[mystat]

  ### Ndenom derivation in case denom = N
  Ndenom <- .N_col
  if (denom == "N") {
    ### as our input dataset has ensured we have unique subjects we can just use the length of x here still safer
    ### to use id variable
    nsub <- length(unique(df[[id]]))
    Ndenom <- nsub
  }

  count_denom_frac <- c(x_stats$n, Ndenom, x_stats$n / Ndenom)
  names(count_denom_frac) <- c("n", "N", "fraction")

  count_frac <- count_denom_frac[c("n", "fraction")]
  count <- count_denom_frac[c("n")]

  y <- list()
  y$count_denom_frac <- count_denom_frac
  y$count_frac <- count_frac
  y$count <- count

  return(y)
}

s_aval_chg_col23_diff <- function(
  df,
  .var,
  .df_row,
  .ref_group,
  .in_ref_col,
  ancova,
  interaction_y,
  interaction_item,
  conf_level,
  variables,
  trt_var,
  ctrl_grp,
  cur_param,
  cur_lvl
) {
  .df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
  df <- subset(df, !is.na(df[[.var]]))
  .ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))

  if (nrow(.df_row) == 0) {
    #### this is only when input row no non-missing records in any of the columns expected to occur for baseline
    #### timepoint for analysis variable change only here we want a blank cell, not a cell with all NA's NULL is
    #### generating a blank cell
    x_stats <- NULL
    mystat1 <- c("mean_ci_3d", "mean_diffci")
  } else if (!ancova) {
    mystat1 <- c("mean_ci_3d", "mean_diffci")

    control <- control_analyze_vars()
    control$conf_level <- conf_level
    x_stats <- s_summarize_desc_j(
      df = df,
      .var = .var,
      .ref_group = .ref_group,
      .in_ref_col = .in_ref_col,
      control = control
    )
  } else {
    mystat1 <- c("lsmean_ci", "lsmean_diffci")

    ### sparse data problems with underlying ancova function 1/ if nrow(.df_row) = 0 NULL (blank columns)

    ### 2/ if nrow(df) = 0 no ancova - lsmean and lsmean diff should be na

    ### 3/ if nrow(df) > 0, & nrow(.ref_group) = 0 ancova for ls mean only, NULL .ref_group -- lsmean diff should
    ### be na

    ### 4/ if nrow(df) > 0, & nrow(.ref_group) > 0 and at least one group with 0 data update levels in
    ### .df_row/df/.ref_group to avoid problems for contrast

    #### by making updates to .df_row/df/.ref_group, situation 3 and 4 could be used together with general case

    .df_row_trtlevels <- unique(.df_row[[trt_var]])

    if (NROW(.df_row_trtlevels) == 0) {
      ### No data at all
      x_stats <- NULL
    } else if (NROW(df) == 0 || NROW(.df_row_trtlevels) == 1) {
      ### current column no data/less than 2 treatment levels

      x_stats <- list()
      x_stats[[mystat1[1]]] <- rep(NA, 3)
      x_stats[[mystat1[2]]] <- rep(NA, 3)
    } else {
      ### ancova situation, and some updates to prevent problems with sparse data
      if ((!ctrl_grp %in% .df_row_trtlevels)) {
        # LS means for current group can be estimated from model, but not difference in LS means set .ref_group
        # to NULL to proceed with s_summarize_ancova_j function update to underlying s_ancova_j to cover NULL
        # ref_group in call
        .ref_group <- NULL
      }
      if (NROW(.df_row_trtlevels) < length(levels(.df_row[[trt_var]]))) {
        # missing levels need to be removed from the factor, in order to have the correct estimates, and avoid
        # errors with underlying tern:::s_ancova function
        .df_row[[trt_var]] <- droplevels(.df_row[[trt_var]])
        df[[trt_var]] <- factor(as.character(df[[trt_var]]), levels = levels(.df_row[[trt_var]]))
        .ref_group[[trt_var]] <- factor(as.character(.ref_group[[trt_var]]), levels = levels(.df_row[[trt_var]]))
      }

      x_stats <- s_summarize_ancova_j(
        df = df,
        .var = .var,
        .ref_group = .ref_group,
        .in_ref_col = .in_ref_col,
        .df_row = .df_row,
        conf_level = conf_level,
        interaction_y = interaction_y,
        interaction_item = interaction_item,
        variables = variables
      )
    }
  }

  y <- list(mean_ci_3d = x_stats[[mystat1[1]]], meandiff_ci_3d = x_stats[[mystat1[2]]])
  return(y)
}


xxd_to_xx <- function(str, d = 0) {
  checkmate::assert_integerish(d, null.ok = TRUE)
  if (checkmate::test_list(str, null.ok = FALSE)) {
    checkmate::assert_list(str, null.ok = FALSE)
    # Or it may be a vector of characters
  } else {
    checkmate::assert_character(str, null.ok = FALSE)
  }

  nmstr <- names(str)

  if (any(grepl("xx.d", str, fixed = TRUE))) {
    checkmate::assert_integerish(d)
    str <- gsub("xx.d", paste0("xx.", strrep("x", times = d)), str, fixed = TRUE)
  }
  str <- stats::setNames(str, nmstr)
  return(str)
}

format_xxd <- function(str, d = 0, .df_row, formatting_fun = NULL) {
  # Handling of data precision
  if (!is.numeric(d)) {
    if (is.character(d) && length(d) == 1) {
      # check if d is a variable name available in .df_row
      if (d %in% names(.df_row)) {
        d <- max(.df_row[[d]], na.rm = TRUE)
      } else {
        message(paste("precision has been reset to d = 0, as variable", d, "not present on input"))
        d <- 0
      }
    }
  }
  # convert xxd type of string to xx
  fmt <- xxd_to_xx(str = str, d = d)

  if (!is.null(formatting_fun)) {
    fmt <- formatting_fun(fmt)
  }

  return(fmt)
}

#' @name a_summarize_aval_chg_diff_j
#'
#' @title Analysis function 3-column presentation
#'
#' @inherit proposal_argument_convention
#'
#' @description Analysis functions to produce a 1-row summary presented in
#' a 3-column layout in the columns: column 1: N, column 2: Value, column 3: change\cr
#' In the difference columns, only 1 column will be presented : difference + CI\cr
#' When ancova = `TRUE`, the presented statistics will be based on ANCOVA method (`s_summarize_ancova_j`).\cr
#' mean and ci (both for Value (column 2) and Chg (column 3)) using statistic `lsmean_ci`\cr
#' mean and ci for the difference column are based on same ANCOVA model using statistic `lsmean_diffci`\cr
#' When ancova = `FALSE`, descriptive statistics will be used instead.\cr
#' In the difference column, the 2-sample t-test will be used.
#'
#' @details See Description
#'
#' @inheritParams proposal_argument_convention
#' @param denom (`string`)\cr choice of denominator for proportions. Options are:
#'   * `N`: number of records in this column/row split.
#' \cr There is no check in place that the current split only has one record per subject.
#' Users should be careful with this.
#'   * `.N_col`: number of records in this column intersection (based on alt_counts_df dataset)
#'   \cr (when alt_counts_df is a single record per subjects, this will match number of subjects)
#'
#' @param d (default = 1) \cr choice of Decimal precision.
#' Note that one extra precision will be added, as means are presented.
#'  \cr Options are:
#'   * numerical(1)
#'   * variable name containing information on the precision, this variable
#'   should be available on input dataset. The content of this variable should
#'   then be an integer.
#'
#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
#' If TRUE Ancova methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
#' @param comp_btw_group (`logical`)\cr If TRUE,
#' \cr When ancova = FALSE, the estimate of between group difference (on CHG)
#' will be based upon a two-sample t-test. \cr
#' \cr When ancova = TRUE, the same ancova model will be used for the estimate of between group difference (on CHG).
#'
#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param conf_level (`proportion`)\cr Confidence level of the interval
#' @param variables (named list of strings)\cr
#' list of additional analysis variables, with expected elements:
#'    * arm (string)\cr
#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
#' Specifically, the first level of arm variable is taken as the reference group.
#'    * covariates (character)\cr
#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
#'
#'
#' @param format_na_str (`string`)\cr
#'
#' @param indatavar (`string`)\cr If not null, variable name to extra subset
#' incoming df to non-missing values of this variable.
#' @param multivars (`string(3)`)\cr Variables names to use in 3-col layout.
#'
#' @param .stats  (named `list`)\cr column statistics to select for the table.
#' The following column names are to be used: `col1`, `col23`, `coldiff`.\cr
#' For `col1`, the following stats can be specified.\cr
#' For `col23`, only `mean_ci_3d` is available. When ancova=`TRUE` these are LS Means, otherwise, arithmetic means.\cr
#' For `coldiff`, only `meandiff_ci_3d` is available. When ancova=`TRUE` these
#' are LS difference in means, otherwise, difference in means based upon 2-sample t-test.\cr
#' @param .formats (named `list`)\cr formats for the column statistics. `xx.d` style formats can be used.
#' @param .formats_fun (named `list`)\cr formatting functions for the column
#' statistics, to be applied after the conversion of `xx.d` style to the
#' appropriate precision.
#'
#' @rdname a_summarize_aval_chg_diff_j
#' @return A function that can be used in an analyze function call
#' @export
#'
#'
#' @examples
#'
#' library(dplyr)
#'
#' ADEG <- data.frame(
#'   STUDYID = c(
#'     'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY',
#'     'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY'
#'   ),
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   TRT01A = c(
#'     'ARMA', 'ARMA', 'ARMA', 'ARMA', 'ARMA', 'Placebo',
#'     'Placebo', 'Placebo', 'ARMA', 'ARMA'
#'   ),
#'   PARAM = c('BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP'),
#'   AVISIT = c(
#'     'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1',
#'     'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1'
#'   ),
#'   AVAL = c(56, 78, 67, 87, 88, 93, 39, 87, 65, 55),
#'   CHG = c(2, 3, -1, 9, -2, 0, 6, -2, 5, 2)
#' )
#'
#' ADEG <- ADEG |>
#'   mutate(
#'     TRT01A = as.factor(TRT01A),
#'     STUDYID = as.factor(STUDYID)
#'   )
#'
#' ADEG$colspan_trt <- factor(ifelse(ADEG$TRT01A == 'Placebo', ' ', 'Active Study Agent'),
#'   levels = c('Active Study Agent', ' ')
#' )
#' ADEG$rrisk_header <- 'Risk Difference (%) (95% CI)'
#' ADEG$rrisk_label <- paste(ADEG$TRT01A, paste('vs', 'Placebo'))
#'
#' colspan_trt_map <- create_colspan_map(ADEG,
#'   non_active_grp = 'Placebo',
#'   non_active_grp_span_lbl = ' ',
#'   active_grp_span_lbl = 'Active Study Agent',
#'   colspan_var = 'colspan_trt',
#'   trt_var = 'TRT01A'
#' )
#' ref_path <- c('colspan_trt', ' ', 'TRT01A', 'Placebo')
#'
#' lyt <- basic_table() |>
#'   ### first columns
#'   split_cols_by(
#'     'colspan_trt',
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by('TRT01A') |>
#'   split_rows_by(
#'     'PARAM',
#'     label_pos = 'topleft',
#'     split_label = 'Blood Pressure',
#'     section_div = ' ',
#'     split_fun = drop_split_levels
#'   ) |>
#'   split_rows_by(
#'     'AVISIT',
#'     label_pos = 'topleft',
#'     split_label = 'Study Visit',
#'     split_fun = drop_split_levels,
#'     child_labels = 'hidden'
#'   ) |>
#'   ## set up a 3 column split
#'   split_cols_by_multivar(
#'     c('AVAL', 'AVAL', 'CHG'),
#'     varlabels = c('n/N (%)', 'Mean (CI)', 'CFB (CI)')
#'   ) |>
#'   split_cols_by('rrisk_header', nested = FALSE) |>
#'   split_cols_by(
#'     'TRT01A',
#'     split_fun = remove_split_levels('Placebo'),
#'     labels_var = 'rrisk_label'
#'   ) |>
#'   ### difference columns : just 1 column & analysis needs to be done on change
#'   split_cols_by_multivar(c('CHG'), varlabels = c(' ')) |>
#'   # the variable passed here in analyze is not used (STUDYID),
#'   # it is a dummy var passing, the function a_summarize_aval_chg_diff_j
#'   # grabs the required vars from cols_by_multivar calls
#'   analyze('STUDYID',
#'     afun = a_summarize_aval_chg_diff_j,
#'     extra_args = list(
#'       format_na_str = '-', d = 0,
#'       ref_path = ref_path, variables = list(arm = 'TRT01A', covariates = NULL)
#'     )
#'   )
#'
#' result <- build_table(lyt, ADEG)
#'
#' result
#' @seealso s_summarize_ancova_j
#' @family Inclusion of ANCOVA Functions
a_summarize_aval_chg_diff_j <- function(
  df,
  .df_row,
  .spl_context,
  ancova = FALSE,
  comp_btw_group = TRUE,
  ref_path = NULL,
  .N_col,
  denom = c("N", ".N_col"),
  indatavar = NULL,
  d = 0,
  id = "USUBJID",
  interaction_y = FALSE,
  interaction_item = NULL,
  conf_level = 0.95,
  variables = list(arm = "TRT01A", covariates = NULL),
  format_na_str = "",
  .stats = list(col1 = "count_denom_frac", col23 = "mean_ci_3d", coldiff = "meandiff_ci_3d"),
  .formats = list(col1 = NULL, col23 = "xx.dx (xx.dx, xx.dx)", coldiff = "xx.dx (xx.dx, xx.dx)"),
  .formats_fun = list(col1 = jjcsformat_count_denom_fraction, col23 = jjcsformat_xx, coldiff = jjcsformat_xx),
  multivars = c("AVAL", "AVAL", "CHG")
) {
  denom <- match.arg(denom)

  if (comp_btw_group && is.null(ref_path)) {
    stop("ref_path cannot be NULL, please specify it. See ?get_ref_info for details.")
  }

  if (!(length(multivars) == 3)) {
    stop("argument multivars must be of length 3.")
  }

  if (!(all(multivars %in% names(df)))) {
    stop("all variables specified in multivars must be available on input dataset df.")
  }

  if (multivars[1] == multivars[2]) {
    multivars[2] <- paste0(multivars[2], "._[[2]]_.")
  }

  if (
    !is.list(.stats) ||
      !all(c("col1", "col23", "coldiff") %in% names(.stats)) ||
      !is.list(.formats) ||
      !all(c("col1", "col23", "coldiff") %in% names(.formats)) ||
      !is.list(.formats_fun) ||
      !all(c("col1", "col23", "coldiff") %in% names(.formats_fun))
  ) {
    stop(paste(
      "Issue a_summarize_aval_chg_diff_j \n.stats/.formats/.formats_fun must",
      "be a list with names c(\"col1\", \"col23\", \"coldiff\")."
    ))
  }

  row_vars <- .spl_context$split
  row_val <- .spl_context$cur_col_split_val

  col_split <- .spl_context$cur_col_split

  ## treatment group value/variable KEY assumption : treatment variable is the last split_col prior to
  ## split_cols_by_multivar
  colvars <- col_split[[NROW(.spl_context)]]
  colvars_multivars <- which(colvars == "multivars")
  if (identical(colvars_multivars, integer(0))) {
    stop("Layout must at least contain a split_cols_by_multivar call.")
  }
  if (colvars_multivars == 1) {
    stop("Layout must at least contain a split_cols_by prior to split_cols_by_multivar call.")
  }
  ## KEY assumption : treatment variable is the last split_col prior to split_cols_by_multivar
  trt_var <- .spl_context$cur_col_split[[NROW(.spl_context)]][colvars_multivars - 1]
  trt_val <- .spl_context$cur_col_split_val[[NROW(.spl_context)]][colvars_multivars - 1]

  mysplitlevel <- length(.spl_context$split)
  cur_lvl <- .spl_context$value[[mysplitlevel]]
  cur_col_id <- .spl_context$cur_col_id[[mysplitlevel]]

  cur_param <- .spl_context$value[[mysplitlevel - 1]]

  indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)

  # Early return if we're not comparing between groups but we're in a difference column
  if (!comp_btw_group && indiffcol) {
    return(rcell(NULL, format = NULL, label = cur_lvl, format_na_str = format_na_str))
  }

  ## variable that is analyzed
  last_val <- utils::tail(.spl_context$cur_col_split_val[[NROW(.spl_context)]], 1)

  # as AVAL will be utilized twice, the second call results in last_val == 'AVAL._[[2]]_.'  take the first part of it
  # in flast_val (will become AVAL) flast_val <- stringr::str_split_1(last_val, pattern = '._')[1]
  flast_val <- unlist(strsplit(last_val, "._"))[1]

  x_stats <- NULL
  fmt_d <- NULL

  .in_ref_col <- FALSE
  .ref_group <- NULL
  if (comp_btw_group) {
    trt_var_refspec <- utils::tail(ref_path, n = 2)[1]
    checkmate::assert_true(identical(trt_var, trt_var_refspec))
    # ctrl_grp
    ctrl_grp <- utils::tail(ref_path, n = 1)

    ### check that ctrl_grp is a level of the treatment variable, in case riskdiff is requested
    if (!ctrl_grp %in% levels(df[[trt_var]])) {
      stop(paste0(
        "control group specification in ref_path argument (",
        ctrl_grp,
        ") is not a level of your treatment group variable (",
        trt_var,
        ")."
      ))
    }

    if (trt_val == ctrl_grp) .in_ref_col <- TRUE

    .ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]
  }

  if (last_val == multivars[1] && !indiffcol) {
    mystat <- .stats[["col1"]]
    if (is.null(.formats[["col1"]])) {
      fmt <- .formats_fun[["col1"]]
    } else {
      fmt <- .formats[["col1"]]
    }

    x_stats <- s_aval_chg_col1(
      df = df,
      .var = flast_val,
      denom = denom,
      .N_col = .N_col,
      id = id,
      indatavar = indatavar
    )
  } else if (last_val %in% multivars[2:3]) {
    x_stats <- s_aval_chg_col23_diff(
      df = df,
      .var = flast_val,
      .df_row = .df_row,
      .ref_group = .ref_group,
      .in_ref_col = .in_ref_col,
      ancova = ancova,
      interaction_y = interaction_y,
      interaction_item = interaction_item,
      conf_level = conf_level,
      variables = variables,
      trt_var = trt_var,
      ctrl_grp = ctrl_grp,
      cur_param = cur_param,
      cur_lvl = cur_lvl
    )

    if (comp_btw_group && indiffcol) {
      mystat1 <- "coldiff"
    } else {
      mystat1 <- "col23"
    }
    mystat <- .stats[[mystat1]]

    fmt_d <- .formats[[mystat1]]
    formatting_fun <- .formats_fun[[mystat1]]

    fmt <- format_xxd(fmt_d, d = d, .df_row = .df_row, formatting_fun = formatting_fun)
  }
  x_stats <- x_stats[[mystat]]

  ##
  ret <- rcell(x_stats, format = fmt, label = cur_lvl, format_na_str = format_na_str)

  return(ret)
}

#' Odds ratio estimation
#'
#' @description `r lifecycle::badge('stable')`
#'
#' @param method (`string`)\cr whether to use the correct (`'exact'`) calculation in the conditional likelihood or one
#'   of the approximations, or the CMH method. See [survival::clogit()] for details.
#'
#' @param df (`data.frame`)\cr input data frame.
#' @param .var (`string`)\cr name of the response variable.
#' @param .df_row (`data.frame`)\cr data frame containing all rows.
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#' @param .ref_group (`data.frame`)\cr reference group data frame.
#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
#' @param variables (`list`)\cr list with arm and strata variable names.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param groups_list (`list`)\cr list of groups for combination.
#'
#' @note
#' The `a_odds_ratio_j()` and `s_odds_ratio_j()` functions have the `_j` suffix to distinguish them
#' from [tern::a_odds_ratio()] and [tern::s_odds_ratio()], respectively.
#' These functions differ as follows:
#'
#' * Additional `method = 'cmh'` option is provided to calculate the Cochran-Mantel-Haenszel estimate.
#' * The p-value is returned as an additional statistic.
#'
#' Once these updates are contributed back to `tern`, they can later be replaced by the `tern` versions.
#'
#' @name odds_ratio
#' @order 1
NULL

#' @describeIn odds_ratio Statistics function which estimates the odds ratio
#'   between a treatment and a control. A `variables` list with `arm` and `strata`
#'   variable names must be passed if a stratified analysis is required.
#'
#' @param na_if_no_events (`flag`)\cr whether the point estimate should be `NA` if there
#'   are no events in one arm. The p-value and confidence interval will still be computed.
#'
#' @return
#' * `s_odds_ratio_j()` returns a named list with the statistics `or_ci`
#'   (containing `est`, `lcl`, and `ucl`), `pval` and `n_tot`.
#'
#' @examples
#' # Unstratified analysis.
#' s_odds_ratio_j(
#'   df = subset(dta, grp == 'A'),
#'   .var = 'rsp',
#'   .ref_group = subset(dta, grp == 'B'),
#'   .in_ref_col = FALSE,
#'   .df_row = dta
#' )
#'
#' # Stratified analysis.
#' s_odds_ratio_j(
#'   df = subset(dta, grp == 'A'),
#'   .var = 'rsp',
#'   .ref_group = subset(dta, grp == 'B'),
#'   .in_ref_col = FALSE,
#'   .df_row = dta,
#'   variables = list(arm = 'grp', strata = 'strata')
#' )
#'
#' # Stratified analysis with CMH.
#' s_odds_ratio_j(
#'   df = subset(dta, grp == 'A'),
#'   method = 'cmh',
#'   .var = 'rsp',
#'   .ref_group = subset(dta, grp == 'B'),
#'   .in_ref_col = FALSE,
#'   .df_row = dta,
#'   variables = list(arm = 'grp', strata = c('strata'))
#' )
#' @export
s_odds_ratio_j <- function(
  df,
  .var,
  .ref_group,
  .in_ref_col,
  .df_row,
  variables = list(arm = NULL, strata = NULL),
  conf_level = 0.95,
  groups_list = NULL,
  na_if_no_events = TRUE,
  method = c("exact", "approximate", "efron", "breslow", "cmh")
) {
  checkmate::assert_flag(na_if_no_events)
  # New: pval here
  y <- list(or_ci = list(), n_tot = list(), pval = list())
  method <- match.arg(method)
  one_group_empty <- nrow(df) == 0 || nrow(.ref_group) == 0

  if (!.in_ref_col) {
    (assert_proportion_value)(conf_level)
    assert_df_with_variables(df, list(rsp = .var))
    assert_df_with_variables(.ref_group, list(rsp = .var))

    if (one_group_empty) {
      y <- list(or_ci = c(est = NA_real_, lcl = 0, ucl = Inf), n_tot = c(n_tot = nrow(df) + nrow(.ref_group)), pval = 1)
    } else if (is.null(variables$strata)) {
      data <- data.frame(
        rsp = c(.ref_group[[.var]], df[[.var]]),
        grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))
      )
      y <- or_glm(data, conf_level = conf_level)
    } else {
      assert_df_with_variables(.df_row, c(list(rsp = .var), variables))
      checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow", "cmh"), empty.ok = FALSE)
      # The group variable prepared for stratified analysis must be synchronized with the combination groups
      # definition.
      if (is.null(groups_list)) {
        ref_grp <- as.character(unique(.ref_group[[variables$arm]]))
        trt_grp <- as.character(unique(df[[variables$arm]]))
        grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)
      } else {
        # If more than one level in reference col.
        reference <- as.character(unique(.ref_group[[variables$arm]]))
        grp_ref_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(reference %in% x))
        ref_grp <- names(groups_list)[grp_ref_flag]

        # If more than one level in treatment col.
        treatment <- as.character(unique(df[[variables$arm]]))
        grp_trt_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(treatment %in% x))
        trt_grp <- names(groups_list)[grp_trt_flag]

        grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)
        grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)
      }

      # New: CMH method
      if (method == "cmh") {
        data <- data.frame(
          rsp = c(.ref_group[[.var]], df[[.var]]),
          grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref")),
          strata = interaction(rbind(.ref_group[variables$strata], df[variables$strata]))
        )

        y <- or_cmh(data, conf_level = conf_level)
      } else {
        # The reference level in `grp` must be the same as in the `rtables` column split.
        data <- data.frame(rsp = .df_row[[.var]], grp = grp, strata = interaction(.df_row[variables$strata]))

        y_all <- or_clogit(data, conf_level = conf_level, method = method)
        checkmate::assert_string(trt_grp)
        # New: pval here
        checkmate::assert_subset(trt_grp, names(y_all$or_ci_pvals))
        y_or_ci_pval <- y_all$or_ci_pvals[[trt_grp]]
        y$or_ci <- y_or_ci_pval[c("est", "lcl", "ucl")]
        y$n_tot <- y_all$n_tot
        y$pval <- y_or_ci_pval["pval"]
      }
    }

    one_group_no_events <- (sum(.ref_group[[.var]]) == 0) || (sum(df[[.var]]) == 0)
    if (na_if_no_events && one_group_no_events) {
      y$or_ci[["est"]] <- NA_real_
    }

    na_because_sparse <- one_group_empty || (na_if_no_events && one_group_no_events)
    if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && !na_because_sparse && method != "approximate") {
      warning(
        "Unable to compute the odds ratio estimate. Please try re-running the function with ",
        "parameter `method` set to \"approximate\"."
      )
    }
  }

  y$or_ci <- with_label(x = y$or_ci, label = paste0("Odds Ratio (", 100 * conf_level, "% CI)"))

  # New: pval here
  y$pval <- unname(y$pval)

  y
}

#' @describeIn odds_ratio Formatted analysis function which is used as `afun`. Note that the
#'   junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
#'
#' @return
#' * `a_odds_ratio_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' set.seed(12)
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c('A', 'B'), each = 50), levels = c('A', 'B')),
#'   strata = factor(sample(c('C', 'D'), 100, TRUE))
#' )
#'
#' a_odds_ratio_j(
#'   df = subset(dta, grp == 'A'),
#'   .var = 'rsp',
#'   ref_path = c('grp', 'B'),
#'   .spl_context = data.frame(
#'     cur_col_split = I(list('grp')),
#'     cur_col_split_val = I(list(c(grp = 'A'))),
#'     full_parent_df = I(list(dta))
#'   ),
#'   .df_row = dta
#' )
#'
#'
#' l <- basic_table() |>
#'   split_cols_by(var = 'grp') |>
#'   analyze(
#'     'rsp',
#'     afun = a_odds_ratio_j,
#'     show_labels = 'hidden',
#'     extra_args = list(
#'       ref_path = c('grp', 'B'),
#'       .stats = c('or_ci', 'pval')
#'     )
#'   )
#'
#' build_table(l, df = dta)
#'
#' l2 <- basic_table() |>
#'   split_cols_by(var = 'grp') |>
#'   analyze(
#'     'rsp',
#'     afun = a_odds_ratio_j,
#'     show_labels = 'hidden',
#'     extra_args = list(
#'       variables = list(arm = 'grp', strata = 'strata'),
#'       method = 'cmh',
#'       ref_path = c('grp', 'A'),
#'       .stats = c('or_ci', 'pval')
#'     )
#'   )
#'
#' build_table(l2, df = dta)
#' @export
#' @order 2
a_odds_ratio_j <- function(
  df,
  .var,
  .df_row,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_odds_ratio_j,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .df_row = list(.df_row),
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "odds_ratio",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Helper functions for odds ratio estimation
#'
#' @description `r lifecycle::badge('stable')`
#'
#' Functions to calculate odds ratios in [s_odds_ratio_j()].
#'
#' @inheritParams odds_ratio
#' @inheritParams proposal_argument_convention
#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally
#'   `strata` for [or_clogit()].
#' # New: pval here
#' @return A named `list` of elements `or_ci`, `n_tot` and `pval`.
#'
#' @seealso [odds_ratio]
#'
#' @name h_odds_ratio
NULL

#' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be
#'   exactly 2 groups in `data` as specified by the `grp` variable.
#'
#' @examples
#' # Data with 2 groups.
#' data <- data.frame(
#'   rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),
#'   grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],
#'   strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],
#'   stringsAsFactors = TRUE
#' )
#'
#' # Odds ratio based on glm.
#' or_glm(data, conf_level = 0.95)
#'
#' @export
or_glm <- function(data, conf_level) {
  checkmate::assert_logical(data$rsp)
  (assert_proportion_value)(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))

  data$grp <- as_factor_keep_attributes(data$grp)
  assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
  formula <- stats::as.formula("rsp ~ grp")
  model_fit <- stats::glm(formula = formula, data = data, family = stats::binomial(link = "logit"))

  # Note that here we need to discard the intercept.
  or <- exp(stats::coef(model_fit)[-1])
  or_ci <- exp(stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE])

  values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
  n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")

  # New: pval here
  pval <- summary(model_fit)$coef[-1, "Pr(>|z|)"]

  list(or_ci = values, n_tot = n_tot, pval = pval)
}

#' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for
#'   the whole data set including all groups, since the results are not the same as when doing
#'   pairwise comparisons between the groups.
#'
#' @examples
#' # Data with 3 groups.
#' data <- data.frame(
#'   rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),
#'   grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],
#'   strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],
#'   stringsAsFactors = TRUE
#' )
#'
#'
#' # Odds ratio based on stratified estimation by conditional logistic regression.
#' or_clogit(data, conf_level = 0.95)
#'
#' @export
or_clogit <- function(data, conf_level, method = "exact") {
  checkmate::assert_logical(data$rsp)
  (assert_proportion_value)(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
  checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
  checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)

  data$grp <- as_factor_keep_attributes(data$grp)
  data$strata <- as_factor_keep_attributes(data$strata)

  # Deviation from convention: `survival::strata` must be simply `strata`.
  strata <- survival::strata
  formula <- stats::as.formula("rsp ~ grp + strata(strata)")
  model_fit <- clogit_with_tryCatch(
    formula = formula,
    data = data,
    method = method
  )

  # New: pval here

  # Create a list with one set of OR estimates, CI and p-value per coefficient, i.e.  comparison of one group vs. the
  # reference group.
  coef_est <- stats::coef(model_fit)
  ci_est <- stats::confint(model_fit, level = conf_level)
  pvals <- summary(model_fit)$coef[, "Pr(>|z|)", drop = FALSE]
  or_ci_pvals <- list()
  for (coef_name in names(coef_est)) {
    grp_name <- gsub("^grp", "", x = coef_name)
    or_ci_pvals[[grp_name]] <- stats::setNames(
      object = c(exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), pvals[coef_name, 1]),
      nm = c("est", "lcl", "ucl", "pval")
    )
  }
  list(or_ci_pvals = or_ci_pvals, n_tot = c(n_tot = model_fit$n))
}

#' @describeIn h_odds_ratio Estimates the odds ratio based on CMH. Note that there must be
#'   exactly 2 groups in `data` as specified by the `grp` variable.
#'
#' @examples
#' # Data with 2 groups.
#' set.seed(123)
#' data <- data.frame(
#'   rsp = as.logical(rbinom(n = 40, size = 1, prob = 0.5)),
#'   grp = letters[sample(1:2, size = 40, replace = TRUE)],
#'   strata = LETTERS[sample(1:2, size = 40, replace = TRUE)],
#'   stringsAsFactors = TRUE
#' )
#'
#' # Odds ratio based on CMH.
#' or_cmh(data, conf_level = 0.95)
#'
#' @export
or_cmh <- function(data, conf_level) {
  checkmate::assert_logical(data$rsp)
  assert_proportion_value(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))

  data$grp <- as_factor_keep_attributes(data$grp)
  assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)

  # first dimension: treatment, control - therefore we reverse the levels order 2nd dimension: TRUE, FALSE 3rd
  # dimension: levels of strata rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
  t_tbl <- table(
    factor(data$grp, levels = rev(levels(data$grp))),
    factor(data$rsp, levels = c("TRUE", "FALSE")),
    data$strata
  )

  trt_ind <- 1
  ctrl_ind <- 2

  resp_ind <- 1
  nonresp_ind <- 2

  n1resp <- t_tbl[trt_ind, resp_ind, ]
  n2resp <- t_tbl[ctrl_ind, resp_ind, ]
  n1non <- t_tbl[trt_ind, nonresp_ind, ]
  n2non <- t_tbl[ctrl_ind, nonresp_ind, ]
  # Example: n2non are the control patient non-responders per stratum.

  # CMH statistic for odds ratio, Treatment over Control
  use_stratum <- (n1resp + n2resp + n1non + n2non) > 0
  n1resp <- n1resp[use_stratum]
  n2resp <- n2resp[use_stratum]
  n1non <- n1non[use_stratum]
  n2non <- n2non[use_stratum]
  n <- n1resp + n2resp + n1non + n2non

  or_num <- sum(n1resp * n2non / n)
  or_denom <- sum(n1non * n2resp / n)
  log_or <- log(or_num) - log(or_denom)
  or <- exp(log_or)

  term1_num <- sum((n1resp + n2non) * n1resp * n2non / n^2)
  term1_denom <- 2 * (sum(n1resp * n2non / n))^2

  term2_num <- sum(((n1resp + n2non) * n1non * n2resp + (n1non + n2resp) * n1resp * n2non) / n^2)
  term2_denom <- 2 * (sum(n1resp * n2non / n)) * (sum(n1non * n2resp / n))

  term3_num <- sum((n1non + n2resp) * n1non * n2resp / n^2)
  term3_denom <- 2 * (sum(n1non * n2resp / n))^2

  var_log_or <- term1_num / term1_denom + term2_num / term2_denom + term3_num / term3_denom
  se_log_or <- sqrt(var_log_or)

  z <- stats::qnorm((1 + conf_level) / 2)
  log_rel_or <- log_or + c(-1, +1) * z * se_log_or
  ci <- exp(log_rel_or)
  or_ci <- stats::setNames(c(or, ci), c("est", "lcl", "ucl"))

  pval <- stats::mantelhaen.test(t_tbl, correct = FALSE)$p.value

  n_tot <- stats::setNames(sum(n), "n_tot")

  list(or_ci = or_ci, n_tot = n_tot, pval = pval)
}

#' Survival time analysis
#'
#' @description `r lifecycle::badge('stable')`
#'
#' The analyze function [kaplan_meier()] creates a layout element to analyze
#' survival time by calculating survival time median, 2 quantiles, each with
#' their confidence intervals, and range (for all, censored, or event patients).
#' The primary analysis variable `vars` is the time variable and the secondary
#' analysis variable `is_event` indicates whether or not an event has occurred.
#'
#' @inheritParams proposal_argument_convention
#' @param control (`list`)\cr parameters for comparison details, specified by using the helper function
#'   [tern::control_surv_time()]. Some possible parameter options are:
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.
#'   * `conf_type` (`string`)\cr confidence interval type. Options are 'plain' (default), 'log', or 'log-log',
#'     see more in [survival::survfit()]. Note option 'none' is not supported.
#'   * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.
#'
#' @note These functions have been forked from the `tern` package file `survival_time.R`.
#'   Here we have the additional features:
#'
#'   * Additional statistics `quantiles_lower`, `quantiles_upper`, `range_with_cens_info` are returned.
#'
#' @examples
#' library(dplyr)
#' library(tern)
#' adtte_f <- tern::tern_ex_adtte |>
#'   filter(PARAMCD == "OS") |>
#'   mutate(
#'     AVAL = tern::day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#' df <- adtte_f |> filter(ARMCD == 'ARM A')
#' @keywords internal
#' @name kaplan_meier
#' @order 1
NULL

#' @describeIn kaplan_meier Statistics function which analyzes survival times using Kaplan-Meier.
#'
#' @return
#' * `s_kaplan_meier()` returns the following statistics:
#'   * `quantiles_lower`: Lower quantile estimate and confidence interval for it.
#'   * `median_ci_3d`: Median survival time and confidence interval for it.
#'   * `quantiles_upper`: Upper quantile estimate and confidence interval for it.
#'   * `range_with_cens_info`: Survival time range with censoring information.
#'
#' @importFrom survival survfit
#'
#' @keywords internal
s_kaplan_meier <- function(df, .var, is_event, control = control_surv_time()) {
  checkmate::assert_string(.var)
  assert_df_with_variables(df, list(tte = .var, is_event = is_event))
  checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)
  checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)

  conf_type <- control$conf_type
  conf_level <- control$conf_level

  checkmate::assert_true(control$quantiles[1] < 0.5)
  checkmate::assert_true(control$quantiles[2] > 0.5)
  quantiles <- c(control$quantiles[1], 0.5, control$quantiles[2])

  formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
  srv_fit <- survival::survfit(formula = formula, data = df, conf.int = conf_level, conf.type = conf_type)
  srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)
  quantiles_lower <- vapply(srv_qt_tab, "[", 1, FUN.VALUE = numeric(1))
  median_ci <- vapply(srv_qt_tab, "[", 2, FUN.VALUE = numeric(1))
  quantiles_upper <- vapply(srv_qt_tab, "[", 3, FUN.VALUE = numeric(1))
  range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)
  range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)
  range <- range_noinf(df[[.var]], na.rm = TRUE)
  lower_censored <- as.numeric(range_censor[1] < range_event[1])
  upper_censored <- as.numeric(range_censor[2] > range_event[2])
  range_with_cens_info <- c(range, lower_censored, upper_censored)
  list(
    quantiles_lower = with_label(
      unname(quantiles_lower),
      paste0(round(quantiles[1] * 100), "th percentile (", f_conf_level(conf_level), ")")
    ),
    median_ci_3d = with_label(unname(median_ci), paste0("Median (", f_conf_level(conf_level), ")")),
    quantiles_upper = with_label(
      unname(quantiles_upper),
      paste0(round(quantiles[3] * 100), "th percentile (", f_conf_level(conf_level), ")")
    ),
    range_with_cens_info = range_with_cens_info
  )
}

#' @describeIn kaplan_meier Formatted analysis function which is used as `afun`
#'
#' @return
#' * `a_kaplan_meier()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' a_kaplan_meier(
#'   df,
#'   .var = 'AVAL',
#'   is_event = 'is_event'
#' )
#'
#' basic_table() |>
#'   split_cols_by(var = 'ARMCD') |>
#'   add_colcounts() |>
#'   analyze(
#'     vars = 'AVAL',
#'     afun = a_kaplan_meier,
#'     var_labels = 'Kaplan-Meier estimate of time to event (months)',
#'     show_labels = 'visible',
#'     extra_args = list(
#'       is_event = 'is_event',
#'       control = control_surv_time(conf_level = 0.9, conf_type = 'log-log')
#'     )
#'   ) |>
#'   build_table(df = adtte_f)
#'
#' @export
#' @order 2
a_kaplan_meier <- function(df, .var, ..., .stats = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_kaplan_meier,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .var = .var, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "kaplan_meier",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Tabulation for Exposure Tables
#'
#'
#' @details
#' Creates statistics needed for standard exposure table
#' This includes differences and 95% CI and total treatment years.
#' This is designed to be used as an analysis (afun in `analyze`) function.
#'
#' @name a_summarize_ex_j
NULL


#' @inheritParams proposal_argument_convention
#' @describeIn a_summarize_ex_j Statistics function needed for the exposure tables
#'
#' @param daysconv conversion required to get the values into days
#' (i.e 1 if original PARAMCD unit is days, 30.4375 if original PARAMCD unit is in months)
#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
#' If TRUE Ancova methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
#' @param comp_btw_group (`logical`)\cr If TRUE,
#' \cr When ancova = FALSE, the estimate of between group difference (on CHG) will be based upon two-sample t-test. \cr
#' \cr When ancova = TRUE, the same ancova model will be used for the estimate of between group difference (on CHG).
#'
#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param conf_level (`proportion`)\cr Confidence level of the interval
#' @param variables (named list of strings)\cr
#' list of additional analysis variables, with expected elements:
#'    * arm (string)\cr
#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
#' Specifically, the first level of arm variable is taken as the reference group.
#'    * covariates (character)\cr
#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
#'
s_summarize_ex_j <- function(
  df,
  .var,
  .df_row,
  .spl_context,
  comp_btw_group = TRUE,
  ref_path = NULL,
  ancova = FALSE,
  interaction_y,
  interaction_item,
  conf_level,
  daysconv,
  variables
) {
  control <- control_analyze_vars()
  control$conf_level <- conf_level
  x_stats <- s_summary(df[[.var]], na.rm = TRUE, .var, control = control)
  ## add extra for subject years
  subj_years <- x_stats[["sum"]] * daysconv / 365.25
  x_stats[["total_subject_years"]] <- c(x_stats[["sum"]], subj_years)
  names(x_stats[["total_subject_years"]]) <- c("total", "subject_years")

  cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
  indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)

  if (indiffcol) {
    # blank out all stats
    x_stats <- sapply(
      names(x_stats),
      FUN = function(x) {
        x_stats[[x]] <- NULL
      },
      simplify = FALSE,
      USE.NAMES = TRUE
    )
    # diff between group will be updated in mean_sd stat
    if (comp_btw_group) {
      trt_var_refpath <- h_get_trtvar_refpath(ref_path, .spl_context, df)
      # trt_var_refpath is list with elements trt_var trt_var_refspec cur_trt_grp ctrl_grp make these elements
      # available in current environment
      trt_var <- trt_var_refpath$trt_var
      trt_var_refspec <- trt_var_refpath$trt_var_refspec
      cur_trt_grp <- trt_var_refpath$cur_trt_grp
      ctrl_grp <- trt_var_refpath$ctrl_grp

      .in_ref_col <- FALSE
      if (trt_var == ctrl_grp) .in_ref_col <- TRUE

      .ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]

      if (ancova) {
        # ancova method for diff between group
        x_stats2 <- s_summarize_ancova_j(
          df = df,
          .var = .var,
          .ref_group = .ref_group,
          .in_ref_col = .in_ref_col,
          .df_row = .df_row,
          conf_level = conf_level,
          interaction_y = interaction_y,
          interaction_item = interaction_item,
          variables = variables
        )
        diffstat <- x_stats2[["lsmean_diffci"]]
      } else {
        # descriptive method for diff between group
        x_stats2 <- s_summarize_desc_j(
          df = df,
          .var = .var,
          .ref_group = .ref_group,
          .in_ref_col = .in_ref_col,
          control = control
        )
        diffstat <- x_stats2[["mean_diffci"]]
      }
      # actual update with the diffstat
      x_stats[["mean_sd"]] <- diffstat
    }
  }

  return(x_stats)
}

#' @title Analysis Function For Exposure Tables
#' @description
#' A function to create the appropriate statistics needed for exposure table
#' @details
#' Creates statistics needed for table. This includes differences and 95% CI and total treatment years.
#' This is designed to be used as an analysis (afun in `analyze`) function.
#' @inheritParams proposal_argument_convention
#'
#' @describeIn a_summarize_ex_j Formatted analysis function which is used as `afun`.
#'
#' @return
#' * `a_summarize_ex_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @aliases a_summarize_ex_j
#' @examples
#' library(dplyr)
#'
#' ADEX <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   TRT01A = c(
#'     'ARMA', 'ARMA', 'ARMA', 'ARMA', 'ARMA',
#'     'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMA'
#'   ),
#'   AVAL = c(56, 78, 67, 87, 88, 93, 39, 87, 65, 55)
#' )
#'
#' ADEX <- ADEX |>
#'   mutate(TRT01A = as.factor(TRT01A))
#'
#' ADEX$colspan_trt <- factor(ifelse(ADEX$TRT01A == 'Placebo', ' ', 'Active Study Agent'),
#'   levels = c('Active Study Agent', ' ')
#' )
#'
#' ADEX$diff_header <- 'Difference in Means (95% CI)'
#' ADEX$diff_label <- paste(ADEX$TRT01A, paste('vs', 'Placebo'))
#'
#' colspan_trt_map <- create_colspan_map(ADEX,
#'   non_active_grp = 'Placebo',
#'   non_active_grp_span_lbl = ' ',
#'   active_grp_span_lbl = 'Active Study Agent',
#'   colspan_var = 'colspan_trt',
#'   trt_var = 'TRT01A'
#' )
#' ref_path <- c('colspan_trt', '', 'TRT01A', 'Placebo')
#'
#' lyt <- basic_table() |>
#'   split_cols_by(
#'     'colspan_trt',
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by('TRT01A') |>
#'   split_cols_by('diff_header', nested = FALSE) |>
#'   split_cols_by(
#'     'TRT01A',
#'     split_fun = remove_split_levels('Placebo'),
#'     labels_var = 'diff_label'
#'   ) |>
#'   analyze('AVAL',
#'     afun = a_summarize_ex_j, var_labels = 'Duration of treatment (Days)',
#'     show_labels = 'visible',
#'     indent_mod = 0L,
#'     extra_args = list(
#'       daysconv = 1,
#'       ref_path = ref_path,
#'       variables = list(arm = 'TRT01A', covariates = NULL),
#'       ancova = TRUE,
#'       comp_btw_group = TRUE
#'     )
#'   )
#'
#' result <- build_table(lyt, ADEX)
#'
#' result
#' @export
a_summarize_ex_j <- function(
  df,
  .var,
  .df_row,
  .spl_context,
  comp_btw_group = TRUE,
  ref_path = NULL,
  ancova = FALSE,
  interaction_y = FALSE,
  interaction_item = NULL,
  conf_level = 0.95,
  variables,
  .stats = c("mean_sd", "median", "range", "quantiles", "total_subject_years"),
  .formats = c(diff_mean_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)")),
  .labels = c(quantiles = "Interquartile range"),
  .indent_mods = NULL,
  na_str = rep("NA", 3),
  daysconv = 1
) {
  if (!is.numeric(df[[.var]])) {
    stop("a_summarize_ex_j issue: input variable must be numeric.")
  }

  if (comp_btw_group && is.null(ref_path)) {
    stop("a_summarize_ex_j issue: argument ref_path cannot be NULL.")
  }

  if (comp_btw_group && ancova && is.null(variables)) {
    stop("a_summarize_ex_j issue: argument variables must be defined when ancova is requested.")
  }

  x_stats <- s_summarize_ex_j(
    df = df,
    .var = .var,
    .df_row = .df_row,
    .spl_context = .spl_context,
    comp_btw_group = comp_btw_group,
    ref_path = ref_path,
    ancova = ancova,
    interaction_y = interaction_y,
    interaction_item = interaction_item,
    conf_level = conf_level,
    daysconv = daysconv,
    variables = variables
  )

  # Fill in formatting defaults
  .stats_in <- .stats
  .stats <- tern_get_stats("analyze_vars_numeric", stats_in = .stats, custom_stats_in = NULL)
  if ("total_subject_years" %in% .stats_in) {
    # place the extra statistic at the appropriate place within .stats vector
    i <- match("total_subject_years", .stats_in)
    x <- .stats_in[i:length(.stats_in)]
    if (length(x) == 1) {
      .stats <- c(.stats, "total_subject_years")
    } else {
      i2 <- min(match(x, .stats), na.rm = TRUE)
      if (i2 == 1) {
        .stats <- c("total_subject_years", .stats)
      } else {
        .stats <- c(.stats[1:(i2 - 1)], "total_subject_years", .stats[i2:length(.stats)])
      }
    }
  }

  .stats_ext <- c(.stats, "diff_mean_est_ci")

  .formats <- junco_get_formats_from_stats(.stats_ext, .formats)
  .labels <- junco_get_labels_from_stats(.stats, .labels, label_attr_from_stats = get_label_attr_from_stats(x_stats))
  .indent_mods <- junco_get_indents_from_stats(.stats, .indent_mods)

  .names <- names(.labels)
  .labels <- .unlist_keep_nulls(.labels)
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
  indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)

  if (indiffcol && comp_btw_group) {
    .formats[["mean_sd"]] <- .formats[["diff_mean_est_ci"]]
  }
  .formats[["diff_mean_est_ci"]] <- NULL

  if (!is.null(na_str)) {
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
  } else {
    .format_na_strs <- NULL
  }

  x_stats <- x_stats[.stats]
  ret <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .names = .names,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )
  return(ret)
}

#' Relative risk estimation
#'
#' The analysis function [a_relative_risk()] is used to create a layout element
#' to estimate the relative risk for response within a studied population. Only
#' the CMH method is available currently.
#' The primary analysis variable, `vars`, is a logical variable indicating
#' whether a response has occurred for each record.
#' A stratification variable must be supplied via the
#' `strata` element of the `variables` argument.
#'
#' @details The variance of the CMH relative risk estimate is calculated using
#'   the Greenland and Robins (1985) variance estimation.
#'
#' @param df (`data.frame`)\cr input data frame.
#' @param .var (`string`)\cr name of the response variable.
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#' @param .ref_group (`data.frame`)\cr reference group data frame.
#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
#' @param variables (`list`)\cr list with strata variable names.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param method (`string`)\cr method to use for relative risk calculation.
#' @param weights_method (`string`)\cr method to use for weights calculation in stratified analysis.
#'
#' @note This has been adapted from the `odds_ratio` functions in the `tern` package.
#'
#' @name relative_risk
NULL

#' @describeIn relative_risk Statistics function estimating the relative risk for response.
#'
#' @return
#' * `s_relative_risk()` returns a named list of elements `rel_risk_ci` and `pval`.
#'
#' @examples
#' nex <- 100 # Number of example rows
#' dta <- data.frame(
#'   'rsp' = sample(c(TRUE, FALSE), nex, TRUE),
#'   'grp' = sample(c('A', 'B'), nex, TRUE),
#'   'f1' = sample(c('a1', 'a2'), nex, TRUE),
#'   'f2' = sample(c('x', 'y', 'z'), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' s_relative_risk(
#'   df = subset(dta, grp == 'A'),
#'   .var = 'rsp',
#'   .ref_group = subset(dta, grp == 'B'),
#'   .in_ref_col = FALSE,
#'   variables = list(strata = c('f1', 'f2')),
#'   conf_level = 0.90
#' )
#' @export
s_relative_risk <- function(
  df,
  .var,
  .ref_group,
  .in_ref_col,
  variables = list(strata = NULL),
  conf_level = 0.95,
  method = "cmh",
  weights_method = "cmh"
) {
  method <- match.arg(method)
  weights_method <- match.arg(weights_method)
  checkmate::assert_character(variables$strata, null.ok = FALSE)
  y <- list(rel_risk_ci = list(), pval = list())

  if (!.in_ref_col) {
    rsp <- c(.ref_group[[.var]], df[[.var]])
    grp <- factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))

    strata_colnames <- variables$strata
    checkmate::assert_character(strata_colnames, null.ok = FALSE)
    strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)

    assert_df_with_variables(df, strata_vars)
    assert_df_with_variables(.ref_group, strata_vars)

    # Merging interaction strata for reference group rows data and remaining
    strata <- c(interaction(.ref_group[strata_colnames]), interaction(df[strata_colnames]))
    strata <- as.factor(strata)

    y <- prop_ratio_cmh(rsp, grp, strata, conf_level)[c("rel_risk_ci", "pval")]

    one_group_no_events <- (sum(.ref_group[[.var]]) == 0) || (sum(df[[.var]]) == 0)
    if (one_group_no_events) {
      y$rel_risk_ci <- c(est = NA_real_, lcl = 0, ucl = Inf)
    }
  }

  y$rel_risk_ci <- with_label(
    x = y$rel_risk_ci,
    label = paste0("Relative risk (", f_conf_level(conf_level), ")")
  )
  y$pval <- unname(y$pval)

  y
}

#' @describeIn relative_risk Formatted analysis function which is used as `afun`. Note that the
#'   junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
#'
#' @return
#' * `a_relative_risk()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' ## 'Mid' case: 4/4 respond in group A, 1/2 respond in group B.
#' nex <- 100 # Number of example rows
#' dta <- data.frame(
#'   'rsp' = sample(c(TRUE, FALSE), nex, TRUE),
#'   'grp' = sample(c('A', 'B'), nex, TRUE),
#'   'f1' = sample(c('a1', 'a2'), nex, TRUE),
#'   'f2' = sample(c('x', 'y', 'z'), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' l <- basic_table() |>
#'   split_cols_by(var = 'grp') |>
#'   analyze(
#'     vars = 'rsp',
#'     afun = a_relative_risk,
#'     extra_args = list(
#'       conf_level = 0.90,
#'       variables = list(strata = 'f1'),
#'       ref_path = c('grp', 'B')
#'     )
#'   )
#'
#' build_table(l, df = dta)
#' @export
#' @order 2
a_relative_risk <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_relative_risk,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "relative_risk",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}


#' @keywords internal
#' @importFrom purrr possibly
safe_mh_test <- purrr::possibly(stats::mantelhaen.test, otherwise = list(p.value = NA_real_))

#' Relative Risk CMH Statistic
#'
#' Calculates the relative risk which is defined as the ratio between the
#' response rates between the experimental treatment group and the control treatment group, adjusted
#' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights.
#'
#' @inheritParams proposal_argument_convention
#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
#'
#' @examples
#' # Cochran-Mantel-Haenszel confidence interval
#'
#' set.seed(2)
#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
#' grp <- sample(c('Placebo', 'Treatment'), 100, TRUE)
#' grp <- factor(grp, levels = c('Placebo', 'Treatment'))
#' strata_data <- data.frame(
#'   'f1' = sample(c('a', 'b'), 100, TRUE),
#'   'f2' = sample(c('x', 'y', 'z'), 100, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' prop_ratio_cmh(
#'   rsp = rsp, grp = grp, strata = interaction(strata_data),
#'   conf_level = 0.90
#' )
#'
#' @export
prop_ratio_cmh <- function(rsp, grp, strata, conf_level = 0.95) {
  grp <- as_factor_keep_attributes(grp)
  strata <- as_factor_keep_attributes(strata)
  has_single_stratum <- nlevels(strata) == 1
  check_diff_prop_ci(
    rsp = rsp,
    grp = grp,
    conf_level = conf_level,
    strata = strata
  )

  if (any(tapply(rsp, strata, length) < 5)) {
    warning("Less than 5 observations in some strata.")
  }

  # first dimension: treatment, control - therefore we reverse the levels order 2nd dimension: TRUE, FALSE 3rd
  # dimension: levels of strata rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
  t_tbl <- table(factor(grp, levels = rev(levels(grp))), factor(rsp, levels = c("TRUE", "FALSE")), strata)

  # Index 1 is for treatment, index 2 is for control, e.g. n1 is number of treatment patients per stratum.
  n1resp <- t_tbl[1, 1, levels(strata)]
  n2resp <- t_tbl[2, 1, levels(strata)]

  t1 <- t_tbl[1, 1:2, , drop = TRUE]
  t2 <- t_tbl[2, 1:2, , drop = TRUE]
  if (has_single_stratum) {
    n1 <- sum(t1)
    n2 <- sum(t2)
    checkmate::assert_count(n1)
    checkmate::assert_count(n2)
  } else {
    n1 <- colSums(t1)
    n2 <- colSums(t2)
    checkmate::assert_integerish(n1)
    checkmate::assert_integerish(n2)
    checkmate::assert_true(identical(length(n1), length(n2)))
  }

  # CMH statistic for relative risk, Treatment over Control
  use_stratum <- (n1 > 0) & (n2 > 0)
  n1 <- n1[use_stratum]
  n2 <- n2[use_stratum]
  n1resp <- n1resp[use_stratum]
  n2resp <- n2resp[use_stratum]
  nresp <- n1resp + n2resp
  n <- n1 + n2

  rel_risk_num <- sum(n1resp * n2 / n)
  rel_risk_denom <- sum(n2resp * n1 / n)
  log_rel_risk <- log(rel_risk_num) - log(rel_risk_denom)
  rel_risk <- exp(log_rel_risk)

  var_num <- sum((n1 * n2 * nresp - n1resp * n2resp * n) / n^2)
  var_denom <- rel_risk_num * rel_risk_denom
  var_log_rel_risk <- var_num / var_denom
  se_log_rel_risk <- sqrt(var_log_rel_risk)

  z <- stats::qnorm((1 + conf_level) / 2)
  log_rel_risk_ci <- log_rel_risk + c(-1, +1) * z * se_log_rel_risk
  ci <- exp(log_rel_risk_ci)
  rel_risk_ci <- stats::setNames(c(rel_risk, ci), c("est", "lcl", "ucl"))

  pval <- safe_mh_test(t_tbl, correct = FALSE)$p.value

  list(rel_risk_ci = rel_risk_ci, pval = pval)
}

#' Helper for Finding AVISIT after which CHG are all Missing
#'
#' @param df (`data.frame`)\cr with `CHG` and `AVISIT` variables.
#'
#' @return A string with either the factor level after which `AVISIT` is all missing,
#'   or `NA`.
#' @export
#'
#' @examples
#' df <- data.frame(
#'   AVISIT = factor(c(1, 2, 3, 4, 5)),
#'   CHG = c(5, NA, NA, NA, 3)
#' )
#' find_missing_chg_after_avisit(df)
#'
#' df2 <- data.frame(
#'   AVISIT = factor(c(1, 2, 3, 4, 5)),
#'   CHG = c(5, NA, 3, NA, NA)
#' )
#' find_missing_chg_after_avisit(df2)
#'
#' df3 <- data.frame(
#'   AVISIT = factor(c(1, 2, 3, 4, 5)),
#'   CHG = c(NA, NA, NA, NA, NA)
#' )
#' find_missing_chg_after_avisit(df3)
find_missing_chg_after_avisit <- function(df) {
  checkmate::assert_data_frame(df)
  checkmate::assert_factor(df$AVISIT, unique = TRUE, any.missing = FALSE)
  checkmate::assert_numeric(df$CHG)

  # Ensure the dataframe is sorted by AVISIT
  df <- df[order(df$AVISIT), ]

  # Last visit with available data.
  visit_levels_available <- as.integer(df[!is.na(df$CHG), ]$AVISIT)

  if (!length(visit_levels_available)) {
    return(levels(df$AVISIT)[1])
  }
  visit_levels_max_available <- max(visit_levels_available)

  # Visits with missing data.
  visit_levels_missing <- as.integer(df[is.na(df$CHG), ]$AVISIT)

  # Missing visits at the end.
  visit_levels_missing_end <- visit_levels_missing[visit_levels_missing > visit_levels_max_available]

  # Return first one if there is any.
  if (length(visit_levels_missing_end)) {
    levels(df$AVISIT)[min(visit_levels_missing_end)]
  } else {
    NA_character_
  }
}

# Copy from rbmi package, because this was only added recently, so not yet available in our package version.

#' Create a `rbmi` ready cluster
#'
#' @param cluster_or_cores Number of parallel processes to use or an existing cluster to make use of
#' @param objects a named list of objects to export into the sub-processes
#' @param packages a character vector of libraries to load in the sub-processes
#'
#' This function is a wrapper around `parallel::makePSOCKcluster()` but takes
#' care of configuring `rbmi` to be used in the sub-processes as well as loading
#' user defined objects and libraries and setting the seed for reproducibility.
#'
#' If `cluster_or_cores` is `1` this function will return `NULL`.
#'
#' If `cluster_or_cores` is a cluster created via `parallel::makeCluster()` then this function
#' just takes care of inserting the relevant `rbmi` objects into the existing cluster.
#'
#' @examples
#' # Basic usage # dontrun because .check_ncores
#' \dontrun{
#' make_rbmi_cluster(5)
#' closeAllConnections()
#'
#' # User objects + libraries
#' VALUE <- 5
#' myfun <- function(x) {
#'   x + day(VALUE) # From lubridate::day()
#' }
#' make_rbmi_cluster(5, list(VALUE = VALUE, myfun = myfun), c('lubridate'))
#' closeAllConnections()
#'
#' # Using a already created cluster
#' cl <- parallel::makeCluster(5)
#' make_rbmi_cluster(cl)
#' closeAllConnections()
#' }
#' @export
make_rbmi_cluster <- function(cluster_or_cores = 1, objects = NULL, packages = NULL) {
  if (is.numeric(cluster_or_cores) && cluster_or_cores == 1) {
    return(NULL)
  } else if (is.numeric(cluster_or_cores)) {
    cl <- parallel::makePSOCKcluster(cluster_or_cores)
  } else if (methods::is(cluster_or_cores, "cluster")) {
    cl <- cluster_or_cores
  } else {
    stop(sprintf("`cluster_or_cores` has unsupported class of: %s", paste(class(cluster_or_cores), collapse = ", ")))
  }

  # Load user defined objects into the globalname space
  if (!is.null(objects) && length(objects)) {
    export_env <- list2env(objects)
    parallel::clusterExport(cl, names(objects), export_env)
  }

  # Load user defined packages
  packages <- c(packages, "assertthat")
  # Remove attempts to load `rbmi` as this will be covered later
  packages <- setdiff(packages, "rbmi")
  devnull <- parallel::clusterCall(
    cl,
    function(pkgs) lapply(pkgs, function(x) library(x, character.only = TRUE)),
    as.list(packages)
  )

  # Ensure reproducibility
  parallel::clusterSetRNGStream(cl, sample.int(1))

  # If user has previously configured `rbmi` sub-processes then early exit
  exported_rbmi <- unlist(parallel::clusterEvalQ(cl, exists("..exported..parallel..rbmi")))
  if (all(exported_rbmi)) {
    return(cl)
  }

  # Ensure that exported and unexported objects are all directly accessible from the globalenv in the sub-processes
  is_in_rbmi_development <- FALSE
  if (is_in_rbmi_development) {
    devnull <- parallel::clusterEvalQ(cl, pkgload::load_all())
  } else {
    devnull <- parallel::clusterEvalQ(cl, {
      .namespace <- getNamespace("rbmi")
      for (.nsfun in ls(.namespace)) {
        assign(.nsfun, get(.nsfun, envir = .namespace))
      }
    })
  }

  # Set variable to signify `rbmi` has been configured
  devnull <- parallel::clusterEvalQ(cl, {
    ..exported..parallel..rbmi <- TRUE
  })

  return(cl)
}

#' Parallelise Lapply
#'
#' Simple wrapper around `lapply` and [`parallel::clusterApplyLB`] to abstract away
#' the logic of deciding which one to use
#' @param cl Cluster created by [`parallel::makeCluster()`] or `NULL`
#' @param fun Function to be run
#' @param x object to be looped over
#' @param ... extra arguments passed to `fun`
par_lapply <- function(cl, fun, x, ...) {
  result <- if (is.null(cl)) {
    lapply(x, fun, ...)
  } else {
    parallel::clusterApplyLB(cl, x, fun, ...)
  }
  return(result)
}

#' Analyse Multiple Imputed Datasets
#'
#' @description
#' This function takes multiple imputed datasets (as generated by
#' the [impute()] function) and runs an analysis function on
#' each of them.
#'
#' @importFrom assertthat assert_that
#'
#' @details
#' This function works by performing the following steps:
#'
#' 1. Extract a dataset from the `imputations` object.
#' 2. Apply any delta adjustments as specified by the `delta` argument.
#' 3. Run the analysis function `fun` on the dataset.
#' 4. Repeat steps 1-3 across all of the datasets inside the `imputations`
#' object.
#' 5. Collect and return all of the analysis results.
#'
#' The analysis function `fun` must take a `data.frame` as its first
#' argument. All other options to [rbmi_analyse()] are passed onto `fun`
#' via `...`.
#' `fun` must return a named list with each element itself being a
#' list containing a single
#' numeric element called `est` (or additionally `se` and `df` if
#' you had originally specified [method_bayes()] or [method_approxbayes()])
#' i.e.:
#' \preformatted{
#' myfun <- function(dat, ...) {
#'     mod_1 <- lm(data = dat, outcome ~ group)
#'     mod_2 <- lm(data = dat, outcome ~ group + covar)
#'     x <- list(
#'         trt_1 = list(
#'             est = coef(mod_1)[['group']],  # Use [[ ]] for safety
#'             se = sqrt(vcov(mod_1)['group', 'group']), # Use ['','']
#'             df = df.residual(mod_1)
#'         ),
#'         trt_2 = list(
#'             est = coef(mod_2)[['group']],  # Use [[ ]] for safety
#'             se = sqrt(vcov(mod_2)['group', 'group']), # Use ['','']
#'             df = df.residual(mod_2)
#'         )
#'      )
#'      return(x)
#'  }
#' }
#'
#' Please note that the `vars$subjid` column (as defined in the original call to
#' [draws()]) will be scrambled in the data.frames that are provided to `fun`.
#' This is to say they will not contain the original subject values and as such
#' any hard coding of subject ids is strictly to be avoided.
#'
#' By default `fun` is the [rbmi_ancova()] function.
#' Please note that this function
#' requires that a `vars` object, as created by [set_vars()], is provided via
#' the `vars` argument e.g. `rbmi_analyse(imputeObj, vars = rbmi::set_vars(...))`. Please
#' see the documentation for [rbmi_ancova()] for full details.
#' Please also note that the theoretical justification for the conditional mean imputation
#' method (`method = method_condmean()` in [draws()]) relies on the fact that ANCOVA is
#' a linear transformation of the outcomes.
#' Thus care is required when applying alternative analysis functions in this setting.
#'
#' The `delta` argument can be used to specify offsets to be applied
#' to the outcome variable in the imputed datasets prior to the analysis.
#' This is typically used for sensitivity or tipping point analyses. The
#' delta dataset must contain columns `vars$subjid`, `vars$visit` (as specified
#' in the original call to [draws()]) and `delta`. Essentially this `data.frame`
#' is merged onto the imputed dataset by `vars$subjid` and `vars$visit` and then
#' the outcome variable is modified by:
#'
#' ```
#' imputed_data[[vars$outcome]] <- imputed_data[[vars$outcome]] + imputed_data[['delta']]
#' ```
#'
#' Please note that in order to provide maximum flexibility, the `delta` argument
#' can be used to modify any/all outcome values including those that were not
#' imputed. Care must be taken when defining offsets. It is recommend that you
#' use the helper function [delta_template()] to define the delta datasets as
#' this provides utility variables such as `is_missing` which can be used to identify
#' exactly which visits have been imputed.
#'
#' @seealso [extract_imputed_dfs()] for manually extracting imputed
#' datasets.
#' @seealso [delta_template()] for creating delta data.frames.
#' @seealso [rbmi_ancova()] for the default analysis function.
#'
#' @param imputations An `imputations` object as created by [impute()].
#' @param fun An analysis function to be applied to each imputed dataset. See details.
#' @param delta A `data.frame` containing the delta transformation to be applied to the imputed
#' datasets prior to running `fun`. See details.
#' @param ... Additional arguments passed onto `fun`.
#' @param cluster_or_cores The number of parallel processes to use when running this function. Can also be a
#' cluster object created by [`make_rbmi_cluster()`]. See the parallelisation section below.
#' @param .validate Should `imputations` be checked to ensure it conforms to the required format
#' (default = `TRUE`) ? Can gain a small performance increase if this is set to `FALSE` when
#' analysing a large number of samples.
#'
#' @section Parallelisation:
#' To speed up the evaluation of `rbmi_analyse()` you can use the `cluster_or_cores` argument to enable parallelisation.
#' Simply providing an integer will get `rbmi` to automatically spawn that many background processes
#' to parallelise across. If you are using a custom analysis function then you need to ensure
#' that any libraries or global objects required by your function are available in the
#' sub-processes. To do this you need to use the [`make_rbmi_cluster()`] function for example:
#' ```
#' my_custom_fun <- function(...) <some analysis code>
#' cl <- make_rbmi_cluster(
#'     4,
#'     objects = list('my_custom_fun' = my_custom_fun),
#'     packages = c('dplyr', 'nlme')
#' )
#' rbmi_analyse(
#'     imputations = imputeObj,
#'     fun = my_custom_fun,
#'     cluster_or_cores = cl
#' )
#' parallel::stopCluster(cl)
#' ```
#'
#' Note that there is significant overhead both with setting up the sub-processes and with
#' transferring data back-and-forth between the main process and the sub-processes. As such
#' parallelisation of the `rbmi_analyse()` function tends to only be worth it when you have
#' `> 2000` samples generated by [`draws()`]. Conversely using parallelisation if your samples
#' are smaller than this may lead to longer run times than just running it sequentially.
#'
#' It is important to note that the implementation of parallel processing within [`analyse()`] has
#' been optimised around the assumption that the parallel processes will be spawned on the same
#' machine and not a remote cluster. One such optimisation is that the required data is saved to
#' a temporary file on the local disk from which it is then read into each sub-process. This is
#' done to avoid the overhead of transferring the data over the network. Our assumption is that
#' if you are at the stage where you need to be parallelising your analysis over a remote cluster
#' then you would likely be better off parallelising across multiple `rbmi` runs rather than within
#' a single `rbmi` run.
#'
#' Finally, if you are doing a tipping point analysis you can get a reasonable performance
#' improvement by re-using the cluster between each call to `rbmi_analyse()` e.g.
#' ```
#' cl <- make_rbmi_cluster(4)
#' ana_1 <- rbmi_analyse(
#'     imputations = imputeObj,
#'     delta = delta_plan_1,
#'     cluster_or_cores = cl
#' )
#' ana_2 <- rbmi_analyse(
#'     imputations = imputeObj,
#'     delta = delta_plan_2,
#'     cluster_or_cores = cl
#' )
#' ana_3 <- rbmi_analyse(
#'     imputations = imputeObj,
#'     delta = delta_plan_3,
#'     cluster_or_cores = cl
#' )
#' parallel::clusterStop(cl)
#' ```
#'
#' @examples
#' library(rbmi)
#' library(dplyr)
#'
#' dat <- antidepressant_data
#' dat$GENDER <- as.factor(dat$GENDER)
#' dat$POOLINV <- as.factor(dat$POOLINV)
#' dat <- expand_locf(
#'   dat,
#'   PATIENT = levels(dat$PATIENT),
#'   # expand by PATIENT and VISIT
#'   VISIT = levels(dat$VISIT),
#'   vars = c("BASVAL", "THERAPY"),
#'   # fill with LOCF BASVAL and THERAPY
#'   group = c("PATIENT"),
#'   order = c("PATIENT", "VISIT")
#' )
#' dat_ice <- dat %>%
#'   arrange(PATIENT, VISIT) %>%
#'   filter(is.na(CHANGE)) %>%
#'   group_by(PATIENT) %>%
#'   slice(1) %>%
#'   ungroup() %>%
#'   select(PATIENT, VISIT) %>%
#'   mutate(strategy = "JR")
#' dat_ice <- dat_ice[-which(dat_ice$PATIENT == 3618), ]
#' vars <- set_vars(
#'   outcome = "CHANGE",
#'   visit = "VISIT",
#'   subjid = "PATIENT",
#'   group = "THERAPY",
#'   covariates = c("THERAPY")
#' )
#' drawObj <- draws(
#'   data = dat,
#'   data_ice = dat_ice,
#'   vars = vars,
#'   method = method_condmean(type = "jackknife"),
#'   quiet = TRUE
#' )
#' references <- c("DRUG" = "PLACEBO", "PLACEBO" = "PLACEBO")
#' imputeObj <- impute(drawObj, references)
#'
#' rbmi_analyse(imputations = imputeObj, vars = vars)
#' @export
rbmi_analyse <- function(imputations, fun = rbmi_ancova, delta = NULL, ..., cluster_or_cores = 1, .validate = TRUE) {
  # nocov

  if (.validate) rbmi::validate(imputations)

  assertthat::assert_that(is.function(fun), msg = "`fun` must be a function")

  assertthat::assert_that(is.null(delta) | is.data.frame(delta), msg = "`delta` must be NULL or a data.frame")

  vars <- imputations$data$vars

  if (.validate) devnull <- lapply(imputations$imputations, function(x) rbmi::validate(x))

  if (!is.null(delta)) {
    expected_vars <- c(vars$subjid, vars$visit, "delta")
    assertthat::assert_that(
      all(expected_vars %in% names(delta)),
      msg = sprintf("The following variables must exist witin `delta`: `%s`", paste0(expected_vars, collapse = "`, `"))
    )
  }

  # Mangle name to avoid any conflicts with user defined objects if running in a cluster
  ..rbmi..analysis..imputations <- imputations
  ..rbmi..analysis..delta <- delta
  ..rbmi..analysis..fun <- fun
  objects <- list(
    ..rbmi..analysis..imputations = ..rbmi..analysis..imputations,
    ..rbmi..analysis..delta = ..rbmi..analysis..delta,
    ..rbmi..analysis..fun = ..rbmi..analysis..fun
  )

  cl <- make_rbmi_cluster(cluster_or_cores)

  if (methods::is(cl, "cluster")) {
    ..rbmi..analysis..data..path <- tempfile()
    saveRDS(objects, file = ..rbmi..analysis..data..path, compress = FALSE)
    devnull <- parallel::clusterExport(cl, "..rbmi..analysis..data..path", environment())
    devnull <- parallel::clusterEvalQ(cl, {
      ..rbmi..analysis..objects <- readRDS(..rbmi..analysis..data..path)
      list2env(..rbmi..analysis..objects, envir = environment())
    })
  }

  # If the user provided the clusters object directly then do not close it on completion
  if (!methods::is(cluster_or_cores, "cluster")) {
    on.exit(
      {
        if (!is.null(cl)) parallel::stopCluster(cl)
      },
      add = TRUE,
      after = FALSE
    )
  }

  # Chunk up requests for significant speed improvement when running in parallel
  number_of_cores <- ifelse(is.null(cl), 1, length(cl))
  indexes <- seq_along(imputations$imputations)
  indexes_split <- split(indexes, (indexes %% number_of_cores) + 1)

  results <- par_lapply(
    cl,
    function(indicies, ...) {
      inner_fun <- function(idx, ...) {
        dat2 <- (utils::getFromNamespace("extract_imputed_df", "rbmi"))(
          ..rbmi..analysis..imputations$imputations[[idx]],
          ..rbmi..analysis..imputations$data,
          ..rbmi..analysis..delta
        )
        ..rbmi..analysis..fun(dat2, ...)
      }
      lapply(indicies, inner_fun, ...)
    },
    indexes_split,
    ...
  ) |>
    unlist(recursive = FALSE, use.names = FALSE)

  # Re-order to ensure results are returned in same order as imputations
  results <- results[order(unlist(indexes_split, use.names = FALSE))]
  names(results) <- NULL

  fun_name <- deparse(substitute(fun))
  if (length(fun_name) > 1) {
    fun_name <- "<Anonymous Function>"
  } else if (is.null(fun_name)) {
    fun_name <- "<NULL>"
  }

  ret <- (utils::getFromNamespace("as_analysis", "rbmi"))(
    results = results,
    fun_name = fun_name,
    delta = delta,
    fun = fun,
    method = imputations$method
  )
  rbmi::validate(ret)
  return(ret)
}

#' @note This has been forked from [tern::h_ancova()], because the new
#'   `weights_emmeans` option was added here.
h_ancova <- function(
  .var,
  .df_row,
  variables,
  weights_emmeans,
  interaction_item = NULL
) {
  checkmate::assert_string(.var)
  checkmate::assert_list(variables)
  checkmate::assert_subset(names(variables), c("arm", "covariates"))

  assert_df_with_variables(
    .df_row,
    list(rsp = .var)
  )
  arm <- variables$arm
  covariates <- variables$covariates
  if (!is.null(covariates) && length(covariates) > 0) {
    var_list <- get_covariates(covariates)
    assert_df_with_variables(
      .df_row,
      var_list
    )
  }
  covariates_part <- paste(covariates, collapse = " + ")
  formula_str <- paste0(.var, " ~ ", arm)
  if (covariates_part != "") {
    formula_str <- paste0(formula_str, "+", covariates_part)
  }
  formula <- stats::as.formula(formula_str)
  specs <- arm
  if (!is.null(interaction_item)) {
    specs <- c(specs, interaction_item)
  }
  lm_fit <- stats::lm(formula = formula, data = .df_row)
  emmeans::emmeans(
    lm_fit,
    specs = specs,
    data = .df_row,
    weights = weights_emmeans
  )
}

#' @title Junco Extended ANCOVA Function
#' @name s_ancova_j
#' @inheritParams tern::s_ancova
#' @param df : need to check on how to inherit params from tern::s_ancova
#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `"counterfactual"` by default.
#' @description Extension to tern:::s_ancova, 3 extra statistics are returned
#'   * `lsmean_se`: Marginal mean and estimated SE in the group.
#'   * `lsmean_ci`: Marginal mean and associated confidence interval in the group.
#'   * `lsmean_diffci`: Difference in mean and associated confidence level in one combined statistic.
#'   In addition, the LS mean weights can be specified.
#'   In addition, also a NULL .ref_group can be specified, the lsmean_diff related estimates will be returned as NA.
#' @export
#' @return  returns a named list of 8 statistics (3 extra compared to `tern:::s_ancova()`).
#' @family Inclusion of ANCOVA Functions
#' @examples
#' library(dplyr)
#' library(tern)
#'
#' df <- iris |> filter(Species == "virginica")
#' .df_row <- iris
#' .var <- "Petal.Length"
#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
#' .ref_group <- iris |> filter(Species == "setosa")
#' conf_level <- 0.95
#' s_ancova_j(df, .var, .df_row, variables, .ref_group, .in_ref_col = FALSE, conf_level)
s_ancova_j <- function(
  df,
  .var,
  .df_row,
  variables,
  .ref_group,
  .in_ref_col,
  conf_level,
  interaction_y = FALSE,
  interaction_item = NULL,
  weights_emmeans = "counterfactual"
) {
  arm <- variables$arm

  .df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
  df <- subset(df, !is.na(df[[.var]]))
  .ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))

  n_obs_trt_lvls <- length(unique(.df_row[[arm]]))

  ### sparse data problems with underlying ancova function
  if (NROW(.df_row) == 0) {
    ret <- NULL
  } else if (NROW(df) == 0 || n_obs_trt_lvls < 2) {
    ## all stats are NA
    ret <- list(
      n = with_label(0, "n"),
      lsmean = with_label(NA, "Adjusted Mean"),
      lsmean_se = with_label(rep(NA, 2), "Adjusted Mean (SE)"),
      lsmean_ci = with_label(
        rep(NA, 3),
        paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
      ),
      lsmean_diff = with_label(NA, "Difference in Adjusted Means"),
      lsmean_diff_ci = with_label(
        rep(NA, 2),
        paste("Difference in Adjusted Means", f_conf_level(conf_level))
      ),
      lsmean_diffci = with_label(
        rep(NA, 3),
        paste0(
          "Difference in Adjusted Means",
          " (",
          f_conf_level(conf_level),
          ")"
        )
      ),
      pval = with_label(NA, "p-value")
    )
  } else {
    if (NROW(.ref_group) == 0) {
      .ref_group <- NULL
    } else if (length(levels(.df_row[[arm]])) > n_obs_trt_lvls) {
      # missing arm levels need to be removed from the factor, in order to have the correct estimates,
      # and avoid errors with further code
      .df_row[[arm]] <- droplevels(.df_row[[arm]])
      df[[arm]] <- factor(
        as.character(df[[arm]]),
        levels = levels(.df_row[[arm]])
      )
      .ref_group[[arm]] <- factor(
        as.character(.ref_group[[arm]]),
        levels = levels(.df_row[[arm]])
      )
    }

    emmeans_fit <- h_ancova(
      .var = .var,
      variables = variables,
      .df_row = .df_row,
      weights_emmeans = weights_emmeans,
      interaction_item = interaction_item
    )
    sum_fit <- summary(
      emmeans_fit,
      level = conf_level
    )
    arm <- variables$arm
    sum_level <- as.character(unique(df[[arm]]))

    # Ensure that there is only one element in sum_level.
    checkmate::assert_scalar(sum_level)

    sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]

    # Get the index of the ref arm
    if (isTRUE(interaction_y)) {
      y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])
      # convert characters selected in interaction_y into the numeric order
      interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)
      sum_fit_level <- sum_fit_level[interaction_y, ]
      # if interaction is called, reset the index
      ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
      ref_key <- utils::tail(ref_key, n = 1)
      ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key
    } else {
      y <- df[[.var]]
      # Get the index of the ref arm when interaction is not called
      ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
      ref_key <- utils::tail(ref_key, n = 1)
    }

    if (.in_ref_col) {
      ret <- list(
        n = with_label(length(y[!is.na(y)]), "n"),
        lsmean = with_label(sum_fit_level$emmean, "Adjusted Mean"),
        lsmean_se = with_label(
          c(sum_fit_level$emmean, sum_fit_level$SE),
          "Adjusted Mean (SE)"
        ),
        lsmean_ci = with_label(
          c(
            sum_fit_level$emmean,
            sum_fit_level$lower.CL,
            sum_fit_level$upper.CL
          ),
          paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
        ),
        lsmean_diff = with_label(
          character(),
          "Difference in Adjusted Means"
        ),
        lsmean_diff_ci = with_label(
          character(),
          paste("Difference in Adjusted Means", f_conf_level(conf_level))
        ),
        lsmean_diffci = with_label(
          character(),
          paste0(
            "Difference in Adjusted Means",
            " (",
            f_conf_level(conf_level),
            ")"
          )
        ),
        pval = with_label(character(), "p-value")
      )
    } else {
      if (!is.null(.ref_group)) {
        # Estimate the differences between the marginal means.
        emmeans_contrasts <- emmeans::contrast(
          emmeans_fit,
          # Compare all arms versus the control arm.
          method = "trt.vs.ctrl",
          # Take the arm factor from .ref_group as the control arm.
          ref = ref_key,
          level = conf_level
        )
        sum_contrasts <- summary(
          emmeans_contrasts,
          # Derive confidence intervals, t-tests and p-values.
          infer = TRUE,
          # Do not adjust the p-values for multiplicity.
          adjust = "none"
        )
        contrast_lvls <- gsub(
          paste0(" - ", .ref_group[[arm]][1], ".*"),
          "",
          sum_contrasts$contrast
        )
        if (!is.null(interaction_item)) {
          sum_contrasts_level <- sum_contrasts[
            grepl(sum_level, contrast_lvls, fixed = TRUE), , drop = FALSE
          ]
        } else {
          sum_contrasts_level <- sum_contrasts[
            (sum_level == contrast_lvls | paste0("(", sum_level, ")") == contrast_lvls), , drop = FALSE
          ]
        }
        if (interaction_y != FALSE) {
          sum_contrasts_level <- sum_contrasts_level[interaction_y, , drop = FALSE]
        }
      } else {
        sum_contrasts_level <- list()
        sum_contrasts_level[["estimate"]] <- NA
        sum_contrasts_level[["lower.CL"]] <- NA
        sum_contrasts_level[["upper.CL"]] <- NA
        sum_contrasts_level[["p.value"]] <- NA
      }
      ret <- list(
        n = with_label(length(y[!is.na(y)]), "n"),
        lsmean = with_label(sum_fit_level$emmean, "Adjusted Mean"),
        lsmean_se = with_label(
          c(sum_fit_level$emmean, sum_fit_level$SE),
          "Adjusted Mean (SE)"
        ),
        lsmean_ci = with_label(
          c(
            sum_fit_level$emmean,
            sum_fit_level$lower.CL,
            sum_fit_level$upper.CL
          ),
          paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
        ),
        lsmean_diff = with_label(
          sum_contrasts_level$estimate,
          "Difference in Adjusted Means"
        ),
        lsmean_diff_ci = with_label(
          c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),
          paste("Difference in Adjusted Means", f_conf_level(conf_level))
        ),
        lsmean_diffci = with_label(
          c(
            sum_contrasts_level$estimate,
            sum_contrasts_level$lower.CL,
            sum_contrasts_level$upper.CL
          ),
          paste0(
            "Difference in Adjusted Means",
            " (",
            f_conf_level(conf_level),
            ")"
          )
        ),
        pval = with_label(sum_contrasts_level$p.value, "p-value")
      )
    }
  }
  return(ret)
}

#' @name s_summarize_ancova_j
#' @title ANCOVA Summary Function
#' @description Combination of tern::s_summary, and ANCOVA based estimates for mean and diff between columns,
#' based on ANCOVA function `s_ancova_j`
#' @inherit s_ancova_j
#' @param ... Additional arguments passed to `s_ancova_j`.
#' @details Combination of tern::s_summary, and ANCOVA based estimates for mean and diff between columns,
#' based on ANCOVA function `s_ancova_j`
#' @return returns the statistics from tern::s_summary(x), appended with a new statistics based upon ANCOVA
#' @export
#' @family Inclusion of ANCOVA Functions
# @seealso s_ancova_j
#' @examples
#' library(dplyr)
#' library(tern)
#'
#' df <- iris |> filter(Species == "virginica")
#' .df_row <- iris
#' .var <- "Petal.Length"
#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
#' .ref_group <- iris |> filter(Species == "setosa")
#' conf_level <- 0.95
#' s_summarize_ancova_j(
#'   df,
#'   .var = .var,
#'   .df_row = .df_row,
#'   variables = variables,
#'   .ref_group = .ref_group,
#'   .in_ref_col = FALSE,
#'   conf_level = conf_level
#' )
s_summarize_ancova_j <- function(
  df,
  .var,
  .df_row,
  .ref_group,
  .in_ref_col,
  ...
) {
  x <- df[[.var]]
  y1 <- s_summary(x)
  y2 <- s_ancova_j(
    df = df,
    .var = .var,
    .ref_group = .ref_group,
    .in_ref_col = .in_ref_col,
    .df_row = .df_row,
    ...
  )
  c(y1, y2)
}

#' @describeIn s_summarize_ancova_j Formatted analysis function which is used as `afun`. Note that the
#'   junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
#'
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#'
#' @return
#' * `a_summarize_ancova_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#'
#' basic_table() |>
#'   split_cols_by("Species") |>
#'   add_colcounts() |>
#'   analyze(
#'     vars = "Petal.Length",
#'     afun = a_summarize_ancova_j,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     table_names = "unadj",
#'     var_labels = "Unadjusted comparison",
#'     extra_args = list(
#'       variables = list(arm = "Species", covariates = NULL),
#'       conf_level = 0.95,
#'       .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means"),
#'       ref_path = c("Species", "setosa")
#'     )
#'   ) |>
#'     analyze(
#'       vars = "Petal.Length",
#'       afun = a_summarize_ancova_j,
#'       show_labels = "hidden",
#'       na_str = tern::default_na_str(),
#'       table_names = "adj",
#'       var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)",
#'       extra_args = list(
#'         variables = list(
#'           arm = "Species",
#'           covariates = c("Sepal.Length", "Sepal.Width")
#'         ),
#'         conf_level = 0.95,
#'         ref_path = c("Species", "setosa")
#'       )
#'     ) |>
#'   build_table(iris)
#'
#' @export
#' @order 2
a_summarize_ancova_j <- function(
  df,
  .var,
  .df_row,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_summarize_ancova_j,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .df_row = list(.df_row),
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "summarize_ancova_j",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' `ANCOVA` Analysis
#'
#' Does the `ANCOVA` analysis, separately for each visit.
#'
#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `ANCOVA` analysis.
#'   The following elements need to be included as character vectors and match corresponding columns
#'   in `data`:
#'
#'   - `response`: the response variable.
#'   - `covariates`: the additional covariate terms (might also include interactions).
#'   - `id`: the subject ID variable (not really needed for the computations but for internal logistics).
#'   - `arm`: the treatment group variable (factor).
#'   - `visit`: the visit variable (factor).
#'
#'   Note that the `arm` variable is by default included in the model, thus should not be part of `covariates`.
#' @param data (`data.frame`)\cr with all the variables specified in
#'   `vars`. Records with missing values in any independent variables
#'   will be excluded.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
#'
#' @return A `tern_model` object which is a list with model results:
#'
#'   - `fit`: A list with a fitted [stats::lm()] result for each visit.
#'   - `mse`: Mean squared error, i.e. variance estimate, for each visit.
#'   - `df`: Degrees of freedom for the variance estimate for each visit.
#'   - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
#'        The attribute `weights` savse the settings used (`weights_emmeans`).
#'   - `vars`: The variable list.
#'   - `labels`: Corresponding list with variable labels extracted from `data`.
#'   - `ref_level`: The reference level for the arm variable, which is always the first level.
#'   - `treatment_levels`: The treatment levels for the arm variable.
#'   - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
#'
#' @export
#' @examples
#' library(mmrm)
#'
#' fit <- fit_ancova(
#'   vars = list(
#'     response = 'FEV1',
#'     covariates = c('RACE', 'SEX'),
#'     arm = 'ARMCD',
#'     id = 'USUBJID',
#'     visit = 'AVISIT'
#'   ),
#'   data = fev_data,
#'   conf_level = 0.9,
#'   weights_emmeans = 'equal'
#' )
#'
fit_ancova <- function(
  vars = list(response = "AVAL", covariates = c(), arm = "ARM", visit = "AVISIT", id = "USUBJID"),
  data,
  conf_level = 0.95,
  weights_emmeans = "proportional"
) {
  labels <- h_labels(vars, data)

  arm_levels <- levels(data[[vars$arm]])
  ref_level <- arm_levels[1]
  trt_levels <- arm_levels[-1]
  visit_levels <- levels(data[[vars$visit]])
  grid <- list(
    factor(arm_levels, levels = arm_levels),
    factor(rep(visit_levels, each = length(arm_levels)), levels = visit_levels)
  ) |>
    stats::setNames(c(vars$arm, vars$visit)) |>
    as.data.frame()
  checkmate::assert_disjunct(vars$arm, vars$covariates)
  covariates_part <- paste(vars$covariates, collapse = " + ")
  formula <- if (covariates_part != "") {
    stats::as.formula(paste0(vars$response, " ~ ", covariates_part, " + ", vars$arm))
  } else {
    stats::as.formula(paste0(vars$response, " ~ ", vars$arm))
  }
  results_by_visit <- Map(
    data = split(data, data[[vars$visit]]),
    grid = split(grid, grid[[vars$visit]]),
    f = function(data, grid) {
      fit <- stats::lm(formula = formula, data = data)
      summary_fit <- summary(fit)
      emmeans_res <- h_get_emmeans_res(fit, vars = vars["arm"], weights = weights_emmeans)
      estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
      estimates[[vars$visit]] <- grid[[vars$visit]]
      estimates <- estimates |> dplyr::relocate(!!vars$arm, !!vars$visit)
      contrasts <- h_get_spec_visit_estimates(
        emmeans_res,
        specs = list(
          coefs = "trt.vs.ctrl",
          grid = grid[-1, ] # Without the reference level row.
        ),
        conf_level = conf_level,
        tests = TRUE,
        ref = ref_level
      )
      relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
      contrasts <- merge(contrasts, relative_reduc_df, by = c(vars$arm, vars$visit), sort = FALSE)
      list(fit = fit, estimates = estimates, contrasts = contrasts, mse = summary_fit$sigma^2, df = summary_fit$df[2])
    }
  )
  lsmeans <- structure(
    list(
      estimates = do.call(rbind, c(lapply(results_by_visit, "[[", "estimates"), make.row.names = FALSE)),
      contrasts = do.call(rbind, c(lapply(results_by_visit, "[[", "contrasts"), make.row.names = FALSE))
    ),
    weights = weights_emmeans
  )
  results <- list(
    fit = lapply(results_by_visit, "[[", "fit"),
    mse = do.call(c, lapply(results_by_visit, "[[", "mse")),
    df = do.call(c, lapply(results_by_visit, "[[", "df")),
    lsmeans = lsmeans,
    vars = vars,
    labels = labels,
    ref_level = ref_level,
    treatment_levels = trt_levels,
    conf_level = conf_level
  )
  class(results) <- "tern_model"
  results
}

#' @name  response_by_var
#' @title Count denom fraction statistic
#'
#' @description Derives the count_denom_fraction statistic (i.e., 'xx /xx (xx.x percent)' )
#'              Summarizes the number of unique subjects with a response = 'Y' for a given variable
#'              (e.g. TRTEMFL) within each category of another variable (e.g., SEX).
#'              Note that the denominator is derived using input df,
#'              in order to have these aligned with alt_source_df, it is expected that df includes all subjects.
#'
#' @details This is an analysis function for use within `analyze`. Arguments
#'          `df`, `.var` will be populated automatically by rtables during
#'          the tabulation process.
#'
#' @param df           Name of dataframe being analyzed.
#' @param labelstr     Custom label for the variable being analyzed.
#' @param .var         Name of the variable being analyzed. Records with non-missing
#'                     values will be counted in the denominator.
#' @param .N_col numeric(1). The total for the current column.
#' @param resp_var     Name of variable, for which, records with a value of 'Y'
#'                     will be counted in the numerator.
#' @param id           Name of column in df which will have patient identifiers
#' @param .format      Format for the count/denominator/fraction output.
#' @param ...          Additional arguments passed to the function.
# @examples #analyze(vars='AGEGR1_DECODE', var_labels = 'Age group (years), n/Ns (%)', afun = response_by_var,
# extra_args = list(resp_var = 'TRTEMFL'))
#' @examples
#'
#' library(dplyr)
#'
#' ADAE <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   SEX_DECODE = c(
#'     'Female', 'Female', 'Male', 'Female', 'Male',
#'     'Female', 'Male', 'Female', 'Male', 'Female'
#'   ),
#'   TRT01A = c(
#'     'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
#'     'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
#'   ),
#'   TRTEMFL = c('Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y')
#' )
#'
#' ADAE <- ADAE |>
#'   mutate(
#'     TRT01A = as.factor(TRT01A),
#'     SEX_DECODE = as.factor(SEX_DECODE)
#'   )
#'
#' lyt <- basic_table() |>
#'   split_cols_by('TRT01A') |>
#'   analyze(
#'     vars = 'SEX_DECODE',
#'     var_labels = 'Sex, n/Ns (%)',
#'     show_labels = 'visible',
#'     afun = response_by_var,
#'     extra_args = list(resp_var = 'TRTEMFL'),
#'     nested = FALSE
#'   )
#'
#' result <- build_table(lyt, ADAE)
#'
#' result
#' @returns a `RowsVerticalSection` for use by the internal tabulation machinery of `rtables`
#' @export

response_by_var <- function(
  df,
  labelstr = NULL,
  .var,
  .N_col,
  resp_var = NULL,
  id = "USUBJID",
  .format = jjcsformat_count_denom_fraction,
  ...
) {
  # Derive statistics: xx / xx (xx.x%)

  if (is.null(resp_var)) {
    stop("afun response_by_var: resp_var cannot be NULL.")
  }

  resp_var_values <- unique(df[[resp_var]][!is.na(df[[resp_var]])])
  if (is.character(df[[resp_var]]) && any(is.na(df[[resp_var]])) && all(resp_var_values == "Y")) {
    stop(paste(
      "afun response_by_var: not clear if missing resp_var should be considered",
      "non-response. Please make it a factor with appropriate Y(/N) levels."
    ))
  }

  if (length(setdiff(resp_var_values, c("Y", "N"))) > 0) {
    stop("afun response_by_var: resp_var must contain only Y/N values.")
  }

  df <- df[!is.na(df[[.var]]), ]

  if (
    (is.factor(df[[resp_var]]) &&
       (identical(levels(df[[resp_var]]), c("Y", "N")) || identical(levels(df[[resp_var]]), c("N", "Y")))) ||
      is.character(df[[resp_var]])
  ) {
    # missing values in resp_var should be excluded, not considered as not met response subject will then not
    # contribute to denominator
    df <- df[!is.na(df[[resp_var]]), ]
  }

  ## in other cases, missing values in resp_var will be considered not met response and subject will contribute to
  ## denominator
  varvec <- df[[.var]]

  # For group summaries, varvec will be a singular value, equal to the current split, whereas for afun summaries,
  # varvec will consist of all possible values of var.
  if (!is.null(labelstr)) {
    levs <- labelstr
  } else {
    levs <- if (is.factor(varvec)) levels(varvec) else unique(varvec)
  }

  fn <- function(levii) {
    dfii <- df[df[[.var]] == levii, ]

    den <- NROW(unique(dfii[, id]))
    num <- NROW(unique(dfii[dfii[[resp_var]] == "Y" & !is.na(dfii[[resp_var]]), id]))

    rcell(c(num * 1, den * 1, num * 1 / den), format = .format)
  }

  cls <- lapply(levs, fn)
  names(cls) <- levs

  # Hand off results to analyze

  in_rows(.list = cls)
}

#' @name a_freq_subcol_j
#'
#' @title Analysis function count and percentage with extra column-subsetting in
#' selected columns (controlled by subcol_* arguments)
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams a_freq_j
#' @param subcol_split Text to search colid to determine whether further subsetting
#'                     should be performed.
#' @param subcol_var Name of variable containing to be searched for the text
#'                     identified in subcol_val argument.
#' @param subcol_val Value to use to perform further data sub-setting.

#' @param denom (`string`)\cr
#' One of \cr
#' \itemize{
#' \item \strong{N_col} Column count, \cr
#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
#' (`.row_df` from the rtables splitting machinery).\cr
#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
#' This higher row-level split is specified in the argument `denom_by`.\cr
#' }
#' @param .formats (named 'character' or 'list')\cr
#' formats for the statistics.
#'
#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
#' @export

a_freq_subcol_j <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  # arguments specific to a_freq_subcol_j
  subcol_split = NULL,
  subcol_var = NULL,
  subcol_val = NULL,
  # arguments specific to a_freq_subcol_j till here
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats = c("count_unique_denom_fraction"),
  .formats = NULL,
  .labels_n = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3)
) {
  denom <- match.arg(denom)

  if (!is.null(labelstr) && is.na(.var)) {
    stop(
      "Argument var must be specified in call to summarize_row_groups when using cfun = a_freq_subcol_j."
    )
  }

  if (denom %in% c("n_altdf") && is.null(.alt_df_full)) {
    stop(".alt_df_full cannot be NULL when denom = n_altdf.")
  }

  res_dataprep <- h_a_freq_dataprep(
    df = df,
    labelstr = labelstr,
    .var = .var,
    val = val,
    drop_levels = FALSE,
    excl_levels = NULL,
    new_levels = NULL,
    new_levels_after = FALSE,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .N_col = .N_col,
    id = id,
    denom = denom,
    variables = NULL,
    label = label,
    label_fstr = label_fstr,
    label_map = label_map,
    .alt_df_full = .alt_df_full,
    denom_by = denom_by,
    .stats = .stats
  )
  # res_dataprep is list with elements
  # df .df_row val
  # drop_levels excl_levels
  # alt_df parentdf new_denomdf
  # .stats
  # make these elements available in current environment
  df <- res_dataprep$df
  .df_row <- res_dataprep$.df_row
  val <- res_dataprep$val
  alt_df <- res_dataprep$alt_df
  parentdf <- res_dataprep$parentdf
  new_denomdf <- res_dataprep$new_denomdf
  .stats <- .stats

  ## colid can be used to figure out if we're in subcolum
  colid <- .spl_context$cur_col_id[[1]]

  ### this is the core code for subsetting to appropriate subcol_val
  insubcol <- grepl(subcol_split, colid, fixed = TRUE)
  if (insubcol) {
    df <- subset(df, df[[subcol_var]] == subcol_val)
  }

  ## the same s-function can be used as in a_freq_j
  x_stats <- s_freq_j(
    df,
    .var = .var,
    .df_row = .df_row,
    val = val,
    alt_df = new_denomdf,
    parent_df = new_denomdf,
    id = id,
    denom = denom,
    .N_col = .N_col,
    countsource = "df"
  )

  .stats_adj <- .stats

  res_prepinrows <- h_a_freq_prepinrows(
    x_stats,
    .stats_adj,
    .formats,
    labelstr,
    label_fstr,
    label,
    .indent_mods,
    .labels_n,
    na_str
  )
  # res_prepinrows is list with elements
  # x_stats .formats .labels .indent_mods .format_na_strs
  # make these elements available in current environment
  x_stats <- res_prepinrows$x_stats
  .formats <- res_prepinrows$.formats
  .labels <- res_prepinrows$.labels
  .indent_mods <- res_prepinrows$.indent_mods
  .format_na_strs <- res_prepinrows$.format_na_strs

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )

  return(inrows)
}

#' @title Function factory for xx style formatting
#' @description A function factory to generate formatting functions for value
#' formatting that support the xx style format and control the rounding method
#'
#' @param roundmethod (`string`)\cr choice of rounding methods. Options are:
#'   * `sas`: the underlying rounding method is `tidytlg::roundSAS`, where \cr
#'   roundSAS comes from this Stack Overflow post https://stackoverflow.com/questions/12688717/round-up-from-5
#'   * `iec`: the underlying rounding method is `round`
#'
#' @param na_str_dflt Character to represent NA value
#' @param replace_na_dflt logical(1). Should an `na_string` of "NA" within
#'    the formatters framework be overridden by `na_str_default`? Defaults to
#'    `TRUE`, as a way to have a different default na string behavior from the
#'    base `formatters` framework.
#' @return `format_xx_fct()` format function that can be used in rtables formatting calls
#' @export
#'
#' @family JJCS formats
#' @examples
#' jjcsformat_xx_SAS <- format_xx_fct(roundmethod = "sas")
#' jjcsformat_xx <- jjcsformat_xx_SAS
#' rcell(c(1.453), jjcsformat_xx("xx.xx"))
#' rcell(c(), jjcsformat_xx("xx.xx"))
#' rcell(c(1.453, 2.45638), jjcsformat_xx("xx.xx (xx.xxx)"))
#'
format_xx_fct <- function(roundmethod = c("sas", "iec"), na_str_dflt = "NE",
                          replace_na_dflt = TRUE) {
  roundmethod <- match.arg(roundmethod)

  if (roundmethod == "sas") {
    roundfunc <- tidytlg::roundSAS
  } else {
    roundfunc <- round
  }

  fnct <- function(str, na_str = na_str_dflt) {
    if (grepl("xxx.", str, fixed = TRUE)) {
      stop(
        "Error: jjcs_format_xx: do not use xxx. in input str, replace by xx. instead."
      )
    }
    if (!grepl("xx", str, fixed = TRUE)) {
      stop("Error: jjcs_format_xx: input str must contain xx.")
    }
    positions <- gregexpr(
      pattern = "xx\\.?x*",
      text = str,
      perl = TRUE
    )
    x_positions <- regmatches(x = str, m = positions)[[1]]
    ### str is splitted into pieces as xx. xx xx.xxx
    ### xx is no rounding
    ### xx. rounding to integer
    ### xx.x rounding to 1 decimal, etc

    no_round <- function(x, na_str = na_str_dflt) {
      if (is.na(x)) {
        return(na_str)
      } else {
        return(x)
      }
    }

    roundings <- lapply(X = x_positions, function(x) {
      y <- strsplit(split = "\\.", x = x)[[1]]
      ### "xx.x" will result in c("xx","x")
      ### "xx." will result in "xx"
      ### "xx" will remain "xx"

      if (x == "xx") {
        rounding <- no_round
      } else {
        rounding <- function(x, na_str = na_str_dflt) {
          if (is.na(x)) {
            return(na_str)
          } else {
            format(
              roundfunc(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)),
              nsmall = ifelse(length(y) > 1, nchar(y[2]), 0)
            )
          }
        }
      }
      return(rounding)
    })
    rtable_format <- function(x, output, na_str = na_str_dflt) {
      if (anyNA(na_str) || (replace_na_dflt && any(na_str == "NA"))) {
        na_inds <- which(is.na(na_str) | (replace_na_dflt & na_str == "NA"))
        na_str[na_inds] <- rep(na_str_dflt, length.out = length(na_str))[na_inds]
      }
      if (length(x) == 0 || isTRUE(all(x == ""))) {
        return(NULL)
      } else if (!length(positions[[1]]) == length(x)) {
        stop(
          "Error: input str in call to jjcs_format_xx must contain same number of xx as the number of stats."
        )
      }

      values <- Map(y = x, fun = roundings, na_str = na_str, function(y, fun, na_str) fun(y, na_str = na_str))
      regmatches(x = str, m = positions)[[1]] <- values
      return(str)
    }
    return(rtable_format)
  }
  return(fnct)
}


jjcsformat_xx_SAS <- format_xx_fct(roundmethod = "sas")
jjcsformat_xx_R <- format_xx_fct(roundmethod = "iec")


### if we ever decide to switch rounding method, we just have to update jjcsformat_xx here

#' @title Formatting of values
#' @name jjcsformat_xx
#' @description jjcs formatting function
#' @param str The formatting that is required specified as a text string, eg "xx.xx"
#' @param na_str character. Na string that will be passed from `formatters` into
#'    our formatting functions.
#' @export
jjcsformat_xx <- jjcsformat_xx_SAS

#' @name count_fraction
#' @title Formatting count and fraction values
#'
#' @description
#'
#' Formats a count together with fraction (and/or denominator) with special
#' consideration when count is 0, or fraction is 1.
#' \cr See also: tern::format_count_fraction_fixed_dp()
#'
#' @inheritParams format_xx_fct
#' @param x `numeric`\cr with elements `num` and `fraction` or `num`, `denom` and `fraction`.
#' @param d numeric(1). Number of digits to round fraction to (default=1)
#' @param ... Additional arguments passed to other methods.
#' @return A string in the format `count / denom (ratio percent)`. If `count`
#' is 0, the format is `0`. If fraction is >0.99, the format is
#' `count / denom (>99.9 percent)`
#' @family JJCS formats
#' @rdname count_fraction
#' @export
#' @examples
#' jjcsformat_count_fraction(c(7, 0.7))
#' jjcsformat_count_fraction(c(70000, 0.9999999))
#' jjcsformat_count_fraction(c(70000, 1))
#'
jjcsformat_count_fraction <- function(
  x,
  d = 1,
  roundmethod = c("sas", "iec"),
  ...
) {
  roundmethod <- match.arg(roundmethod)
  attr(x, "label") <- NULL
  if (any(is.na(x))) {
    return("-")
  }

  checkmate::assert_vector(x)
  checkmate::assert_integerish(x[1])
  assert_proportion_value(
    x[2],
    include_boundaries = TRUE
  )

  fraction <- x[2]

  if (isTRUE(all.equal(fraction, 1))) fraction <- 1

  if (roundmethod == "sas") {
    fmtpct <- format(tidytlg::roundSAS(fraction * 100, d), nsmall = d)
  } else {
    fmtpct <- format(round(fraction * 100, d), nsmall = d)
  }

  result <- if (x[1] == 0) {
    "0"
  } else if (fraction == 1) {
    ## per conventions still report as 100.0%
    paste0(x[1], " (100.0%)")
  } else if (fmtpct == format(0, nsmall = d)) {
    # else if (100*x[2] < 10**(-d)) {
    ### example pct = 0.09999 ### <0.1% (even if fmtpct == 0.1,
    # but the actual value of pct <0.1)
    paste0(x[1], " (<", 10**(-d), "%)")
  } else if (fmtpct == format(100, nsmall = d)) {
    # else if (100*x[2] > 100-10**(-d)) {
    ### example pct = 99.90001 ### >99.9% (even if fmtpct == 99.9,
    # but the actual value of pct >99.9)
    paste0(x[1], " (>", 100 - 10**(-d), "%)")
  } else {
    paste0(x[1], " (", fmtpct, "%)")
  }
  return(result)
}

#' @title Formatting count, denominator and fraction values
#'
#' @inheritParams count_fraction
#' @param ... Additional arguments passed to other methods.
#' @export
#' @rdname count_denom_fraction
#' @examples
#' jjcsformat_count_denom_fraction(c(7, 10, 0.7))
#' jjcsformat_count_denom_fraction(c(70000, 70001, 70000 / 70001))
#' jjcsformat_count_denom_fraction(c(235, 235, 235 / 235))
jjcsformat_count_denom_fraction <- function(
  x,
  d = 1,
  roundmethod = c("sas", "iec"),
  ...
) {
  roundmethod <- match.arg(roundmethod)
  attr(x, "label") <- NULL
  if (any(is.na(x))) {
    return("-")
  }
  checkmate::assert_vector(x)
  checkmate::assert_integerish(x[1])
  assert_proportion_value(
    x[3],
    include_boundaries = TRUE
  )

  fraction <- x[3]
  if (x[2] == x[1]) fraction <- 1

  fmt_x12 <- paste0(x[1], "/", x[2])

  if (roundmethod == "sas") {
    fmtpct <- format(tidytlg::roundSAS(fraction * 100, d), nsmall = d)
  } else {
    fmtpct <- format(round(fraction * 100, d), nsmall = d)
  }

  result <- if (x[1] == 0) {
    # "0"
    # same as in general situation
    paste0(fmt_x12, " (", fmtpct, "%)")
  } else if (100 * fraction == 100) {
    paste0(fmt_x12, " (100.0%)")
  } else if (100 * fraction < 10**(-d)) {
    ### example pct = 0.09999 ### <0.1% (even if fmtpct == 0.1, but the actual value of pct <0.1)
    paste0(fmt_x12, " (<", 10**(-d), "%)")
  } else if (100 * fraction > 100 - 10**(-d)) {
    ### example pct = 99.90001 ### >99.9% (even if fmtpct == 99.9, but the actual value of pct >99.9)
    paste0(fmt_x12, " (>", 100 - 10**(-d), "%)")
  } else {
    paste0(fmt_x12, " (", fmtpct, "%)")
  }
  return(result)
}

#' @title Formatting fraction, count and denominator values
#'
#' @inheritParams count_fraction
#' @param ... Additional arguments passed to other methods.
#' @export
#' @rdname fraction_count_denom
#' @examples
#' jjcsformat_fraction_count_denom(c(7, 10, 0.7))
#' jjcsformat_fraction_count_denom(c(70000, 70001, 70000 / 70001))
#' jjcsformat_fraction_count_denom(c(235, 235, 235 / 235))
jjcsformat_fraction_count_denom <- function(
  x,
  d = 1,
  roundmethod = c("sas", "iec"),
  ...
) {
  roundmethod <- match.arg(roundmethod)
  attr(x, "label") <- NULL
  if (any(is.na(x))) {
    return("-")
  }
  checkmate::assert_vector(x)
  checkmate::assert_integerish(x[1])
  assert_proportion_value(
    x[3],
    include_boundaries = TRUE
  )

  fraction <- x[3]
  if (x[2] == x[1]) fraction <- 1

  fmt_x12 <- paste0(x[1], "/", x[2])

  if (roundmethod == "sas") {
    fmtpct <- format(tidytlg::roundSAS(fraction * 100, d), nsmall = d)
  } else {
    fmtpct <- format(round(fraction * 100, d), nsmall = d)
  }

  result <- if (x[1] == 0) {
    # "0"
    # same as in general situation
    paste0("(", fmt_x12, ")")
  } else if (100 * fraction == 100) {
    paste0("100.0%", " (", fmt_x12, ")")
  } else if (100 * fraction < 10**(-d)) {
    ### example pct = 0.09999 ### <0.1% (even if fmtpct == 0.1, but the actual value of pct <0.1)
    paste0("<", 10**(-d), "%", " (", fmt_x12, ")")
  } else if (100 * fraction > 100 - 10**(-d)) {
    ### example pct = 99.90001 ### >99.9% (even if fmtpct == 99.9, but the actual value of pct >99.9)
    paste0(">", 100 - 10**(-d), "%", " (", fmt_x12, ")")
  } else {
    paste0(fmtpct, "%", " (", fmt_x12, ")")
  }
  return(result)
}

#' @title Function factory for p-value formatting
#'
#' @description A function factory to generate formatting functions for p-value
#' formatting that support rounding close to the significance level specified
#'
#' @param alpha `number`\cr the significance level to account for during rounding.
#' @return The p-value in the standard format. If `count` is 0, the format is `0`.
#'   If it is smaller than 0.001, then `<0.001`, if it is larger than 0.999, then
#'   `>0.999` is returned. Otherwise, 3 digits are used. In the special case that
#'   rounding from below would make the string equal to the specified `alpha`,
#'   then a higher number of digits is used to be able to still see the difference.
#'   For example, 0.0048 is not rounded to 0.005 but stays at 0.0048 if `alpha = 0.005`
#'   is set.
#'
#' @family JJCS formats
#' @export
#'
#' @examples
#' my_pval_format <- jjcsformat_pval_fct(0.005)
#' my_pval_format(0.2802359)
#' my_pval_format(0.0048)
#' my_pval_format(0.00499)
#' my_pval_format(0.004999999)
#' my_pval_format(0.0051)
#' my_pval_format(0.0009)
#' my_pval_format(0.9991)
#'
jjcsformat_pval_fct <- function(alpha = 0.05) {
  checkmate::assert_number(alpha, lower = 0, upper = 1)

  function(x, ...) {
    checkmate::assert_number(
      x,
      lower = 0,
      upper = 1 + .Machine$double.eps, # Be a bit tolerant here.
      na.ok = TRUE
    )
    if (is.na(x)) {
      "NE"
    } else if (x < 0.001) {
      "<0.001"
    } else if (x > 0.999) {
      ">0.999"
    } else {
      xx_format <- "xx.xxx"
      res <- jjcsformat_xx(xx_format)(x)
      while (as.numeric(res) == alpha && x < alpha) {
        # Increase precision by 1 digit until the result
        # is different from threshold alpha.
        xx_format <- paste0(xx_format, "x")
        res <- jjcsformat_xx(xx_format)(x)
      }
      res
    }
  }
}

#' @title Function factory for range with censoring information formatting
#' @description A function factory to generate formatting functions for range formatting
#'   that includes information about the censoring of survival times.
#'
#' @param str `string`\cr the format specifying the number of digits to be used,
#'   for the range values, e.g. `"xx.xx"`.
#' @return A function that formats a numeric vector with 4 elements:
#'   - minimum
#'   - maximum
#'   - censored minimum? (1 if censored, 0 if event)
#'   - censored maximum? (1 if censored, 0 if event)
#'   The range along with the censoring information is returned as a string
#'   with the specified numeric format as `(min, max)`, and the `+` is appended
#'   to `min` or `max` if these have been censored.
#'
#' @family JJCS formats
#' @export
#'
#' @examples
#' my_range_format <- jjcsformat_range_fct("xx.xx")
#' my_range_format(c(0.35235, 99.2342, 1, 0))
#' my_range_format(c(0.35235, 99.2342, 0, 1))
#' my_range_format(c(0.35235, 99.2342, 0, 0))
#' my_range_format(c(0.35235, 99.2342, 1, 1))
jjcsformat_range_fct <- function(str) {
  format_xx <- jjcsformat_xx(str)

  function(x, ...) {
    checkmate::assert_numeric(
      x,
      len = 4L,
      finite = TRUE,
      any.missing = FALSE
    )
    checkmate::assert_true(all(x[c(3, 4)] %in% c(0, 1)))

    res <- vapply(x[c(1, 2)], format_xx, character(1))
    if (x[3] == 1) res[1] <- paste0(res[1], "+")
    if (x[4] == 1) res[2] <- paste0(res[2], "+")
    paste0("(", res[1], ", ", res[2], ")")
  }
}

#' Split Function for Compliance Columns (TEFSCNCMP01 e.g.)
#'
#' Here we just split into 3 columns for expected, received and missing visits.
#'
#' @inheritParams proposal_argument_convention
#' @param ret (`list`)\cr result from previous split function steps.
#' @param spl (`split`)\cr split object.
#' @param fulldf (`data.frame`)\cr full data frame.
#' @param vals (`character`)\cr values to use for the split.
#' @param trim (`logical`)\cr whether to trim the values.
#'
#' @note This split function is used in the proportion table TEFSCNCMP01 and similar ones.
#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
#'   post-processing function.
cmp_post_fun <- function(ret, spl, fulldf, .spl_context) {
  short_split_result(
    expected = "Expected, N",
    received = "Received, n (%)",
    missing = "Missing, n (%)",
    fulldf = fulldf
  )
}
#' @rdname cmp_post_fun
#' @export
cmp_split_fun <- make_split_fun(post = list(cmp_post_fun))

#' @title Summary Analysis Function for Compliance Columns (TEFSCNCMP01 e.g.)
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format, for use in a split content row. The denominator here is
#'   from the expected visits column.
#' @inherit proposal_argument_convention
#' @param variables (`list`)\cr with variable names of logical columns for
#'   `expected`, `received` and `missing` visits.
#' @param formats (`list`)\cr with the `count_percent` format to use for the received
#'   and missing visits columns.
#' @return The [rtables::in_rows()] result with the counts and proportion statistics.
#' @seealso [cmp_post_fun()] for the corresponding split function.
#' @export
cmp_cfun <- function(df, labelstr, .spl_context, variables, formats) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  this_afun_col <- this_col_split[2]

  exp <- df[[variables$expected]]
  checkmate::assert_logical(exp)
  n_exp <- sum(exp)
  rec <- df[[variables$received]]
  mis <- df[[variables$missing]]

  if (this_afun_col == "expected") {
    in_rows(n_exp, .labels = labelstr, .formats = "xx.")
  } else if (this_afun_col == "received") {
    checkmate::assert_logical(rec)
    checkmate::assert_true(all(exp[rec]))

    # Check if count_percent format is available
    if (!is.null(formats) && !("count_percent" %in% names(formats))) {
      stop("'count_percent' format must be provided in the formats argument")
    }

    in_rows(sum(rec) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
  } else if (this_afun_col == "missing") {
    checkmate::assert_logical(mis)
    checkmate::assert_true(all(exp[mis]))
    checkmate::assert_true(!any(rec[mis]))

    # Check if count_percent format is available
    if (!is.null(formats) && !("count_percent" %in% names(formats))) {
      stop("'count_percent' format must be provided in the formats argument")
    }

    in_rows(sum(mis) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
  }
}


## contribute to formatters
#' @name inches_to_spaces
#' @title Conversion of inches to spaces
#' @param ins numeric. Vector of widths in inches
#' @param fontspec font_spec. The font specification to use
#' @param raw logical(1). Should the answer be returned unrounded
#'  (`TRUE`), or rounded to the nearest reasonable value (`FALSE`,
#'  the default)
#' @param tol numeric(1). The numeric tolerance,  values
#'  between an integer `n`, and `n+tol` will be returned
#'  as `n`, rather than `n+1`, if `raw == FALSE`. Ignored
#'  when `raw` is `TRUE`.
#' @export
inches_to_spaces <- function(ins, fontspec, raw = FALSE, tol = sqrt(.Machine$double.eps)) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  spcw <- grid::convertWidth(grid::unit(1, "strwidth", " "), "inches", valueOnly = TRUE)
  ans <- ins / spcw
  if (!raw) {
    win_tol <- ans - floor(ans) < tol
    ans[win_tol] <- floor(ans)
    ans[!win_tol] <- ceiling(ans)
  }
  ans
}

#' @importFrom formatters wrap_string_ttype
ttype_wrap_vec <- function(vec, fontspec, width, wordbreak_ok = TRUE, ...) {
  lapply(
    vec,
    wrap_string_ttype,
    width_spc = width,
    fontspec = fontspec,
    wordbreak_ok = wordbreak_ok,
    ...
  )
}

#' @name check_wrap_nobreak
#' @title Check Word Wrapping
#' @description Check a set of column widths for word-breaking wrap behavior
#' @param tt TableTree
#' @param colwidths numeric. Column widths (in numbers of spaces under `fontspec`)
#' @param fontspec font_spec.
#'
#' @return `TRUE` if the wrap is able to be done without breaking words,
#' `FALSE` if wordbreaking is required to apply `colwidths`
#' @rdname check_wrap_nobreak
#' @export
check_wrap_nobreak <- function(tt, colwidths, fontspec) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  mpf <- matrix_form(tt, fontspec = fontspec)
  strs <- mf_strings(mpf)
  colok <- vapply(
    seq_len(ncol(strs)),
    function(i) {
      res <- tryCatch(
        ttype_wrap_vec(strs[, i, drop = TRUE], colwidths[i], fontspec = fontspec, wordbreak_ok = FALSE),
        error = function(e) e
      )
      !methods::is(res, "error")
    },
    TRUE
  )
  all(colok)
}

#' Colwidths for all columns to be forced on one page
#'
#' @param tt TableTree object to calculate column widths for
#' @param fontspec Font specification object
#' @param col_gap Column gap in spaces
#' @param rowlabel_width Width of row labels in spaces
#' @param print_width_ins Print width in inches
#' @param landscape Whether the output is in landscape orientation
#' @param lastcol_gap Whether to include a gap after the last column
smart_colwidths_1page <- function(
  tt,
  fontspec,
  col_gap = 6L,
  rowlabel_width = inches_to_spaces(2, fontspec),
  print_width_ins = ifelse(landscape, 11, 8.5) - 2.12,
  landscape = FALSE,
  lastcol_gap = TRUE
) {
  total_cpp <- floor(inches_to_spaces(print_width_ins, fontspec = fontspec, raw = TRUE))

  nc <- ncol(tt)
  remain <- total_cpp - rowlabel_width - col_gap * (nc - !lastcol_gap)

  c(rowlabel_width - col_gap, spread_integer(remain, nc))
}

spaces_to_inches <- function(spcs, fontspec) {
  nchar_ttype(" ", fontspec, raw = TRUE) * spcs
}

no_cellwrap_colwidths <- function(tt, fontspec, col_gap = 4L, label_width_ins = 2) {
  if (is.null(col_gap)) {
    col_gap <- 4L
  }
  mpf <- matrix_form(tt, TRUE, FALSE, fontspec = fontspec, col_gap = col_gap)
  strmat <- mf_strings(mpf)
  label_width_max <- inches_to_spaces(label_width_ins, fontspec)

  nchar_mat <- nchar_ttype(strmat[-seq_len(mf_nlheader(mpf)), , drop = FALSE],
                           fontspec = fontspec)

  label_width <- min(label_width_max,
                     max(nchar_mat[, 1, drop = TRUE]))
  col_maxes <- apply(nchar_mat[, -1, drop = FALSE], 2, max)
  c(label_width, col_maxes + col_gap)
}

pack_into_lines2 <- function(strs, wrdwidths = nchar_ttype(strs), colwidth, fontspec) {
  if (length(wrdwidths) == 0 || (length(wrdwidths) == 1 && wrdwidths <= colwidth)) {
    return(1)
  }
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }

  csums <- cumsum(wrdwidths + c(0, rep(1, length(wrdwidths) - 1)))
  oneline_wdth <- sum(wrdwidths) + length(wrdwidths) - 1
  if (colwidth >= ceiling(oneline_wdth)) {
    return(1)
  }
  lines <- 0
  wrdsused <- 0
  widthused <- 0
  index_seq <- seq_along(wrdwidths)
  totwrds <- length(wrdwidths)
  adj <- 0
  ## finite precision arithmetic is a dreamscape of infinite wonder
  tol <- sqrt(.Machine$double.eps)
  while (wrdsused < length(wrdwidths)) {
    csums_i <- csums - widthused

    fit <- which(index_seq > wrdsused & csums_i <= colwidth + tol)
    widthused <- sum(widthused, wrdwidths[fit], length(fit))
    wrdsused <- wrdsused + length(fit)
    lines <- lines + 1
  }
  lines
}

recursive_add_poss <- function(
  wlst,
  cur_lst,
  ubnd_width,
  lbnd_width,
  ubnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = ubnd_width)$lines,
  lbnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = lbnd_width)$lines,
  fontspec
) {
  if (ubnd_width <= lbnd_width + 1 + sqrt(.Machine$double.eps)) {
    return(cur_lst)
  }
  curw <- floor((ubnd_width + lbnd_width) / 2)
  curlnsdf <- calc_total_lns(wlst, fontspec = fontspec, colwidth = curw)
  to_add <- list(curlnsdf)

  if (curlnsdf$lines != lbnd_lines) {
    to_add <- c(
      to_add,
      recursive_add_poss(
        wlst = wlst,
        fontspec = fontspec,
        ubnd_width = curw,
        ubnd_lines = curlnsdf$lines,
        lbnd_width = lbnd_width,
        lbnd_lines = lbnd_lines,
        cur_lst = list()
      )
    )
  }
  if (curlnsdf$lines != ubnd_lines) {
    to_add <- c(
      to_add,
      recursive_add_poss(
        wlst = wlst,
        fontspec = fontspec,
        ubnd_width = ubnd_width,
        ubnd_lines = ubnd_lines,
        lbnd_width = curw,
        lbnd_lines = curlnsdf$lines,
        cur_lst = list()
      )
    )
  }

  c(cur_lst, to_add)
}

calc_total_lns <- function(wlst, colwidth, fontspec, lns_per_pg = 50) {
  lns <- vapply(
    seq_along(wlst),
    function(i) {
      pack_into_lines2(wrdwidths = wlst[[i]], colwidth = colwidth, fontspec = fontspec)
    },
    1
  )
  nonblnks <- !vapply(wlst, function(x) length(x) == 0, TRUE)
  celllns <- lns[-1]
  cllsum <- sum(celllns)
  hdr <- lns[1]
  data.frame(
    colwidth = colwidth,
    lines = cllsum + ceiling(cllsum / lns_per_pg) * hdr,
    cell_lines = cllsum,
    lbl_lines = hdr,
    min_cell_lines = min(1, celllns[nonblnks], na.rm = TRUE),
    max_cell_lines = max(celllns)
  )
}


calc_poss_lines <- function(wlst, lbound, avail_spc, fontspec) {
  minposs <- calc_total_lns(wlst, lbound + avail_spc, fontspec)
  maxposs <- calc_total_lns(wlst, lbound, fontspec)

  retlst <- list(minposs, maxposs)

  retlst <- recursive_add_poss(
    wlst = wlst,
    ubnd_width = lbound + avail_spc,
    lbnd_width = lbound,
    cur_lst = retlst,
    fontspec = fontspec
  )
  do.call(rbind, retlst)
}


make_poss_wdf <- function(
  mpf,
  incl_header = FALSE,
  col_gap = 3,
  pg_width_ins = 8.88,
  fontspec = font_spec("Times", 9, 1.2)
) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  if (!methods::is(mpf, "MatrixPrintForm")) {
    mpf <- matrix_form(mpf, fontspec = fontspec, col_gap = col_gap)
  }
  strs <- mf_strings(mpf)
  if (!incl_header) {
    strs <- strs[-seq_len(mf_nlheader(mpf)), ]
  }
  nc <- ncol(strs)
  nr <- nrow(strs)
  ## strip out markup so we are not over countin (by as much)
  strs <- matrix(gsub("~[{[][[:alpha:]]+ ([^]}]+)[]}]", "\\1", strs), ncol = nc, nrow = nr)

  possrows <- lapply(seq_len(ncol(strs)), function(ii) {
    res <- one_col_strs(strs[, ii, drop = TRUE], fontspec = fontspec, col_gap = col_gap)
    res$col_num <- ii
    res
  })

  possdf <- do.call(rbind, possrows)
  o <- order(possdf$col_num, possdf$colwidth)
  possdf <- possdf[o, ]
  possdf
}

#'
#' @param mpf (`listing_df` or `MatrixPrintForm` derived thereof)\cr The listing
#' calculate column widths for.
#' @param incl_header (`logical(1)`)\cr Should the constraint to not break up
#' individual words be extended to words in the column labels? Defaults to `TRUE`
#' @param col_gap (`numeric(1)`)\cr Amount of extra space (in spaces) to
#' assume between columns. Defaults to `0.5`
#' @param pg_width_ins (`numeric(1)`)\cr Number of inches in width for
#'  *the portion of the page the listing will be printed to*. Defaults to `8.88`
#'  which corresponds to landscape orientation on a standard page after margins.
#' @param fontspec (`font_spec`)\cr Defaults to Times New Roman 8pt font with 1.2 line
#' height.
#' @param verbose (`logical(1)`)\cr Should additional information messages be
#' displayed during the calculation of the column widths? Defaults to `FALSE`.
#' @returns A vector of column widths suitable to use in `tt_to_tlgrtf` and
#' other exporters.
#' @rdname def_colwidths
#' @export
listing_column_widths <- function(
  mpf,
  incl_header = TRUE,
  col_gap = 0.5,
  pg_width_ins = 8.88,
  fontspec = font_spec("Times", 8, 1.2),
  verbose = FALSE
) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  possdf <- make_poss_wdf(
    mpf = mpf,
    incl_header = incl_header,
    col_gap = col_gap,
    fontspec = fontspec,
    pg_width_ins = pg_width_ins
  )
  optimal <- optimal_widths(
    possdf = possdf,
    tot_spaces = inches_to_spaces(pg_width_ins, fontspec = fontspec),
    verbose = verbose
  )
  optimal$colwidth
}

find_free_colspc <- function(curposs, fullposs, thresh = 0.99, skip = integer(), verbose = FALSE) {
  orig_curposs <- curposs
  maxlns_ind <- which.max(curposs$cell_lines)
  longestcol <- curposs$col_num[maxlns_ind]
  maxlns <- curposs$cell_lines[maxlns_ind]
  adjrow_inds <- setdiff(which(curposs$cell_lines < thresh * maxlns), skip)
  for (arowi in adjrow_inds) {
    col <- curposs$col_num[arowi]
    colwidthii <- curposs$colwidth[arowi]
    fp_ind <- with(fullposs, min(which(col_num == col & cell_lines <= maxlns & colwidth < colwidthii)))
    if (is.finite(fp_ind)) {
      if (verbose) {
        oldwdth <- curposs$colwidth[arowi]
        newwdth <- fullposs$colwidth[fp_ind]
        msg <- sprintf("adjusting column %d width from %d to %d", col, oldwdth, newwdth)
        message(msg)
      }
      curposs[arowi, ] <- fullposs[fp_ind, ]
    }
  }
  curposs
}

constrict_lbl_lns <- function(curdf, possdf, avail_spc, verbose = TRUE) {
  old_lbl_lns <- max(curdf$lbl_lines)
  cols_to_pack <- which(curdf$lbl_lns == old_lbl_lns)
  olddf <- curdf
  success <- TRUE
  for (ii in cols_to_pack) {
    colii <- curdf$col_num[ii]
    cwidthii <- curdf$colwidth[ii]
    possdfii <- possdf[possdf$col_num == colii & possdf$lbl_lines < old_lbl_lns, ]
    if (nrow(possdfii) == 0) {
      success <- FALSE
      break
    }
    newrow <- possdfii[ii, ]
    if (newrow$colwidth - cwidthii > avail_spc) {
      success <- FALSE
      break
    }
    ## assuming sorted
    curdf[ii, ] <- newrow
    avail_spc <- avail_spc + cwidthii - newrow$colwidth
  }

  if (verbose) {
    if (success) {
      msg <- paste(
        "overall number of label rows successfully reduced. Cols affected: ",
        paste(curdf$col_num[cols_to_pack], collapse = ", ")
      )
    } else {
      msg <- paste("Unable to reduce label rows required.")
    }
  }

  if (!success) {
    curdf <- olddf
  }
  curdf
}

optimal_widths <- function(possdf, tot_spaces = 320, max_lbl_lines = 3, verbose = FALSE) {
  odf <- order(possdf$col_num, possdf$colwidth)
  possdf <- possdf[odf, ]
  badlbl <- which(possdf$lbl_lines > max_lbl_lines)
  if (length(badlbl > 0)) {
    if (verbose) {
      message("Excluding ", length(badlbl), " column widths for labels taking over ", max_lbl_lines, " lines.")
    }
    possdf <- possdf[-badlbl, ]
    possdf <- possdf[possdf$lbl_lines <= max_lbl_lines, , drop = FALSE]
  }
  full_possdf <- possdf
  ## already ordered by colnum then width so this the first of each colwidth is the min width for that col
  dups <- duplicated(possdf$col_num)
  curdf <- possdf[!dups, ]
  possdf <- possdf[dups, ] ## without rows for ones in curdf
  spcleft <- tot_spaces - sum(curdf$colwidth)
  if (verbose) {
    message(
      "Optimizng Column Widths\n",
      "Initial lines required: ",
      max(curdf$lines),
      "\n",
      "Available adjustment: ",
      spcleft,
      " spaces\n"
    )
  }
  done <- FALSE
  while (!done) {
    oldwdths <- curdf$colwidth
    curdf <- constrict_lbl_lns(curdf, possdf, verbose = verbose)
    if (all.equal(curdf$colwidth, oldwdths)) {
      done <- TRUE
    }
  }
  change <- TRUE
  while (spcleft > 0 && change && nrow(possdf) > 0) {
    change <- FALSE
    ii <- which.max(curdf$cell_lines)
    spcleft <- tot_spaces - sum(curdf$colwidth)
    colii <- curdf$col_num[ii]
    bef_lns <- curdf$cell_lines[ii]
    bef_width <- curdf$colwidth[ii]
    nextlns <- max(curdf$cell_lines[-ii])
    cand_row_cond <- possdf$col_num == colii & possdf$cell_lines < bef_lns & possdf$colwidth - bef_width <= spcleft
    canddf <- possdf[cand_row_cond, , drop = FALSE]
    if (nrow(canddf) > 0) {
      more_than_next <- canddf$cell_lines >= nextlns
      if (any(more_than_next)) {
        candrow <- canddf[max(which(more_than_next)), ]
      } else {
        candrow <- canddf[nrow(canddf), ]
      }

      if (verbose) {
        message(
          "COL ",
          colii,
          " width: ",
          bef_width,
          "->",
          candrow$colwidth,
          " lines req: ",
          bef_lns,
          "->",
          candrow$cell_lines
        )
      }
      change <- TRUE
      curdf[ii, ] <- candrow
    }
  }
  curdf
}


one_col_strs <- function(strcol, col_gap = 2, fontspec) {
  strspls <- strsplit(strcol, split = "(-| (?=[^/]))", perl = TRUE)
  strspl_widths <- lapply(strspls, nchar_ttype, fontspec = fontspec, raw = TRUE)
  lbound_raw <- max(unlist(strspl_widths))
  lbound <- ceiling(lbound_raw + 2 * col_gap)
  ret <- calc_poss_lines(strspl_widths, lbound, 50, fontspec = fontspec)
  ret
}

## we have permission from the formatters maintainer to use this
## unexported function
j_mf_col_widths <- utils::getFromNamespace("mf_col_widths", "formatters")

#' @name def_colwidths
#'
#' @title Define Column Widths
#'
#' @description
#' function for aiding more personalized column widths in case default is not desired.
#'
#' @param tt input Tabletree
#' @param fontspec Font specification
#' @param label_width_ins Label Width in Inches.
#' @param col_gap Column gap.
#' @param type Type of the table tree, used to determine column width calculation method.
#' @examples # colwidths <- def_colwidths(result, font_spec('Times', 9L, 1.2), col_gap = 7L, label_width_ins = 2)
#' @export
#'
def_colwidths <- function(tt, fontspec, label_width_ins, col_gap, type = tlg_type(tt)) {
  if (type == "Figure") {
    ret <- NULL
  } else if (type == "Table") {
    if (
      is.list(tt) &&
        !methods::is(tt, "MatrixPrintForm") &&
        !is.null(j_mf_col_widths(tt[[1]]))
    ) {
      ret <- j_mf_col_widths(tt[[1]])
    } else {
      ret <- no_cellwrap_colwidths(tt, fontspec, col_gap = col_gap, label_width_ins = label_width_ins)
    }
  } else {
    ret <- listing_column_widths(tt, fontspec = fontspec, col_gap = col_gap)
  }
  ret
}

make_dps_regex <- function(keyword, type = c("[", "{")) {
  mustart <- match.arg(type)
  muend <- ifelse(mustart == "[", "]", "}")

  paste0("[~][", mustart, "]", keyword, " ([^", muend, "]+)[", muend, "]")
}

handle_one_markup <- function(strs, keyword, rtfstart, rtfend) {
  start <- ifelse(nzchar(rtfstart), paste0("\\", rtfstart, " "), "")
  end <- ifelse(nzchar(rtfstart), paste0("\\", rtfend, " "), "")
  out <- gsub(make_dps_regex(keyword), paste0(start, "\\1", end), strs)
  out <- gsub(make_dps_regex(keyword, "{"), paste0(start, "\\1", end), out)
  out
}


dps_markup_df <- tibble::tribble(
  ~keyword,
  ~rtfstart,
  ~rtfend,
  "super",
  "\\super",
  "\\nosupersub",
  "sub",
  "\\sub",
  "\\nosupersub",
  "optional",
  "",
  ""
)


#' Default String Mapping for Special Characters
#'
#' A tibble that maps special characters to their UTF-8 equivalents for use in RTF output.
#' Currently it maps ">=" and "<=" to the Unicode characters.
#'
#' @return A tibble with columns 'pattern' and 'value', where 'pattern' contains
#'   the string to be replaced and 'value' contains the replacement.
#'
#' @export
#' @keywords internal
default_str_map <- tibble::tribble(
  ~pattern,
  ~value,
  ">=",
  intToUtf8(strtoi(2265, base = 16)),
  "<=",
  intToUtf8(strtoi(2264, base = 16))
)

convert_dps_markup <- function(strs, markup_df = dps_markup_df) {
  for (i in seq_len(nrow(markup_df))) {
    strs <- handle_one_markup(strs, markup_df$keyword[i], markup_df$rtfstart[i], markup_df$rtfend[i])
  }
  strs
}

strmodify <- function(strs, replacement_str = default_str_map) {
  map_tbl <- replacement_str
  if (!is.null(map_tbl) && nrow(map_tbl) > 0) {
    for (i in seq_len(nrow(map_tbl))) {
      pattern <- map_tbl$pattern[[i]]
      value <- map_tbl$value[i]
      strs <- gsub(pattern, value, strs, fixed = TRUE)
    }
  }
  return(strs)
}

prep_strs_for_rtf <- function(strs, string_map = default_str_map, markup_df = dps_markup_df) {
  strs <- convert_dps_markup(strs, markup_df)
  strs <- strmodify(strs, string_map)
  return(strs)
}


#' Relabel Variables in a Dataset
#'
#' This function relabels variables in a dataset based on a provided list of labels.
#' It can either replace existing labels or only add labels to variables without them.
#'
#' @param x (`data.frame`)\cr dataset containing variables to be relabeled.
#' @param lbl_list (`list`)\cr named list of labels to apply to variables.
#' @param replace_existing (`logical`)\cr if TRUE, existing labels will be replaced;
#'   if FALSE, only variables without labels will be updated.
#'
#' @return The dataset with updated variable labels.
#'
#' @export
#' @keywords internal
var_relabel_list <- function(x, lbl_list, replace_existing = TRUE) {
  if (replace_existing) {
    vars_to_relabel <- intersect(names(x), names(lbl_list))
  } else {
    get_variables_with_empty_labels <- function(x) {
      labels <- var_labels(x)
      mask <- lapply(labels, is.na) |> unlist()
      return(names(labels[mask]))
    }

    vars_without_labels <- get_variables_with_empty_labels(x)
    vars_to_relabel <- intersect(vars_without_labels, names(lbl_list))
  }
  do.call(var_relabel, c(list(x = x), lbl_list[vars_to_relabel]))
}

#' @name safe_prune_table
#'
#' @title Safely Prune Table With Empty Table Message If Needed
#'
#' @inheritParams rtables::prune_table
#'
#' @param empty_msg character(1). The message to place in the table
#' if no rows were left after pruning
#'
#' @param spancols logical(1). Should `empty_msg` be spanned
#' across the table's columns (`TRUE`) or placed in the
#' rows row label (`FALSE`). Defaults to `FALSE` currently.
#'
#' @rdname safe_prune_table
#' @return `tt` pruned based on the arguments, or, if
#' pruning would remove all rows, a TableTree with the
#' same column structure, and one row containing the
#' empty message spanning all columns
#'
#' @export
#' @examples
#' # always prune
#' prfun <- function(tt) TRUE
#'
#' lyt <- basic_table() |>
#'   split_cols_by('ARM') |>
#'   split_cols_by('STRATA1') |>
#'   split_rows_by('SEX') |>
#'   analyze('AGE')
#' tbl <- build_table(lyt, ex_adsl)
#'
#' safe_prune_table(tbl, prfun)
safe_prune_table <- function(
  tt,
  prune_func = prune_empty_level,
  stop_depth = NA,
  empty_msg = " - No Data To Display - ",
  spancols = FALSE
) {
  ret <- prune_table(tt = tt, prune_func = prune_func, stop_depth = stop_depth, depth = 0)
  if (is.null(ret)) {
    ret <- tt[integer(), , keep_titles = TRUE, keep_topleft = TRUE, keep_footers = TRUE]

    if (spancols) {
      ## this will eventually be the only option...
      ret <- sanitize_table_struct(ret, empty_msg = empty_msg)
    } else {
      tree_children(ret) <- list(rrowl(empty_msg, rep(" ", ncol(tt))))
    }
  }
  ret
}

#' @name count_pruner
#'
#' @title Count Pruner
#'
#' @description
#' This is a pruning constructor function which identifies records to be pruned
#' based on the count (assumed to be the first statistic displayed when a compound
#' statistic (e.g., ## / ## (XX.X percent) is presented).
#'
#' @param  count   count threshold.  Function will keep all records strictly greater
#'                 than this threshold.
#' @param  cols    column path (character or integer (column indices))
#' @param  cat_include     Category to be considered for pruning
#' @param  cat_exclude logical Category to be excluded from pruning
#' @export
#'
#'
#' @examples
#'
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   TRT01P = factor(
#'     c(
#'       'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
#'       'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
#'      )
#'   ),
#'   FASFL = c('Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'Y'),
#'   SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
#'   PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
#' )
#'
#' lyt <- basic_table() |>
#'   split_cols_by('TRT01P') |>
#'   add_overall_col('Total') |>
#'   analyze('FASFL',
#'     var_labels = 'Analysis set:',
#'     afun = a_freq_j,
#'     extra_args = list(label = 'Full', val = 'Y'),
#'     show_labels = 'visible'
#'   ) |>
#'   analyze('SAFFL',
#'     var_labels = 'Analysis set:',
#'     afun = a_freq_j,
#'     extra_args = list(label = 'Safety', val = 'Y'),
#'     show_labels = 'visible'
#'   ) |>
#'   analyze('PKFL',
#'     var_labels = 'Analysis set:',
#'     afun = a_freq_j,
#'     extra_args = list(label = 'PK', val = 'Y'),
#'     show_labels = 'visible'
#'   )
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#'
#' # use pruning function to prune where total column has >0 count,
#' # but exclude pruning safety set row
#' result <- prune_table(
#'   result,
#'   prune_func = count_pruner(cat_exclude = c('Safety'), cols = 'Total')
#' )
#'
#' result
#'
#' @rdname count_pruner
#' @returns  function that can be utilized as pruning function in prune_table
#'
count_pruner <- function(count = 0, cat_include = NULL, cat_exclude = NULL, cols = c("TRT01A")) {
  function(tt) {
    # Do not ever prune the following rows.  a row that should be kept in the table will get the value of FALSE

    if (
      !methods::is(tt, "TableRow") ||
        methods::is(tt, "LabelRow") ||
        obj_label(tt) == " " ||
        (!is.null(cat_include) &&
           !obj_label(tt) %in% cat_include) ||
        (!is.null(cat_exclude) && obj_label(tt) %in% cat_exclude)
    ) {
      return(FALSE)
    }

    # Check the remaining rows to see if any meet the specified threshold.

    if (!is.null(cols)) {
      tt <- subset_cols(tt, cols)
    }

    # init return value to FALSE (not remove row)
    remove <- FALSE

    colpaths <- col_paths(tt)
    # identify non relative risk columns as in rrisk columns first element is not a count, but diff percentage with
    # small total columns and count > 0 (eg count = 1, n per group = 10), you can run into count1 = 1, countpbo =
    # 0, diffpct = 10, this row should not be considered though
    cp_nonrelrisk <- vapply(
      colpaths,
      function(pth) {
        !any(grepl("rrisk", tolower(pth)))
      },
      FUN.VALUE = TRUE
    )

    ## only continue if at least one non relative risk column selected
    if (any(cp_nonrelrisk)) {
      # get cell_values of non rel risk columns
      cell_vals <- cell_values(tt)[cp_nonrelrisk]

      len_cell_vals <- lapply(cell_vals, function(x) {
        length(x)
      })

      if (any(len_cell_vals == 0)) {
        stop("column cell values has not appropriate structure (a column with NULL value).")
      }

      # get count (first element)
      counts <- unlist(
        lapply(cell_vals, function(x) {
          x[[1]]
        }),
        use.names = FALSE
      )

      # check that we do have counts only
      checkmate::assert_integerish(counts)

      keep <- counts > count
      # the row should be kept if at least one column has count above threshold
      keep <- any(keep)

      # pruning function should return TRUE if row has to be removed, ie opposite of keep
      remove <- !keep
    }

    return(remove)
  }
}


#' @name bspt_pruner
#'
#' @title Pruning Function for pruning based on a fraction and/or a difference from the control arm
#'
#' @description
#' This is a pruning constructor function which identifies records to be pruned
#' based on the the fraction from the percentages. In addition to just looking at a fraction within an arm
#' this function also allows further flexibility to also prune based on a comparison versus the control arm.
#' @param  fraction   fraction threshold.  Function will keep all records strictly greater
#'                 than this threshold.
#' @param  cols    column path.
#' @param  keeprowtext     Row to be excluded from pruning.
#' @param reg_expr Apply keeprowtext as a regular expression (grepl with fixed = TRUE)
#' @param  control        Control Group
#' @param  diff_from_control  Difference from control threshold.
#' @param  only_more_often    TRUE: Only consider when column pct is more often
#' than control. FALSE: Also select a row where column pct is less often than
#' control and abs(diff) above threshold
#'
#' @export
#'
#'
#' @examples
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   TRT01P = c(
#'     'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
#'     'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
#'   ),
#'   FASFL = c('Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'Y'),
#'   SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
#'   PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
#' )
#'
#' ADSL <- ADSL |>
#'   dplyr::mutate(TRT01P = as.factor(TRT01P)) |>
#'   dplyr::mutate(SAFFL = factor(SAFFL, c("Y", "N"))) |>
#'   dplyr::mutate(PKFL = factor(PKFL, c("Y", "N")))
#'
#' lyt <- basic_table() |>
#'   split_cols_by('TRT01P') |>
#'   add_overall_col('Total') |>
#'
#'   split_rows_by(
#'     "FASFL",
#'     split_fun = drop_and_remove_levels("N"),
#'     child_labels = "hidden"
#'   ) |>
#'   analyze('FASFL',
#'     var_labels = 'Analysis set:',
#'     afun = a_freq_j,
#'     show_labels = 'visible',
#'     extra_args = list(label = 'Full', .stats = "count_unique_fraction")
#'   ) |>
#'
#'   split_rows_by(
#'     "SAFFL",
#'     split_fun = remove_split_levels("N"),
#'     child_labels = "hidden"
#'   ) |>
#'   analyze('SAFFL',
#'     var_labels = 'Analysis set:',
#'     afun = a_freq_j,
#'     show_labels = 'visible',
#'     extra_args = list(label = 'Safety', .stats = "count_unique_fraction")
#'   ) |>
#'
#'   split_rows_by(
#'     "PKFL",
#'     split_fun = remove_split_levels("N"),
#'     child_labels = "hidden"
#'   ) |>
#'   analyze('PKFL',
#'     var_labels = 'Analysis set:',
#'     afun = a_freq_j,
#'     show_labels = 'visible',
#'     extra_args = list(label = 'PK', .stats = "count_unique_fraction")
#'   )
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#'
#' # use pruning function to prune rows where it doesn't meet 5% criteria
#' # in the total column but it will not
#' # prune the Safety row regardless
#' result <- prune_table(
#'   result,
#'   prune_func = bspt_pruner(
#'     fraction = 0.05,
#'     keeprowtext = 'Safety',
#'     cols = c('Total')
#'   )
#' )
#'
#' result
#' @rdname bspt_pruner
#' @returns  function that can be utilized as pruning function in prune_table
#'
bspt_pruner <- function(
  fraction = 0.05,
  keeprowtext = "Analysis set: Safety",
  reg_expr = FALSE,
  control = NULL,
  diff_from_control = NULL,
  only_more_often = TRUE,
  cols = c("TRT01A")
) {
  if (is.null(fraction) && is.null(diff_from_control)) {
    stop("At least one of fraction or diff_from_control must be non-NULL.")
  }
  if (!is.null(diff_from_control) && is.null(control)) {
    stop("control must be specified when diff_from_control is not NULL.")
  }

  function(tt) {
    # Do not ever prune the following rows.
    if (!methods::is(tt, "TableRow") || methods::is(tt, "LabelRow")) {
      return(FALSE)
    }

    if (
      reg_expr &&
        any(sapply(keeprowtext, function(x) {
          grepl(x, obj_label(tt), fixed = TRUE)
        }))
    ) {
      return(FALSE)
    }
    if (!reg_expr && obj_label(tt) %in% keeprowtext) {
      return(FALSE)
    }

    # init return value to FALSE (not remove row)
    remove <- FALSE

    # needed later for control column
    tt_all_cols <- tt

    if (!is.null(cols)) {
      tt <- subset_cols(tt, cols)
    }

    colpaths <- col_paths(tt)
    # identify non relative risk columns
    cp_nonrelrisk <- vapply(
      colpaths,
      function(pth) {
        !any(grepl("rrisk", tolower(pth)))
      },
      FUN.VALUE = TRUE
    )

    ## only continue if at least one non relative risk column selected
    if (any(cp_nonrelrisk)) {
      # get rid of rel risk columns (if present)
      cell_vals <- cell_values(tt)[cp_nonrelrisk]

      len_cell_vals <- lapply(cell_vals, function(x) {
        length(x)
      })

      if (any(len_cell_vals < 2)) {
        stop("column cell values has not appropriate structure (less than 2 values in cell).")
      }

      # get count and percentage columns counts in first col pcts in second col
      counts <- unname(lst_slicer(cell_vals, 1, numeric(1)))
      pcts <- unname(lst_slicer(cell_vals, 2, numeric(1)))

      checkmate::check_integerish(counts)
      # similarly check that pcts is indeed a percentage
      if (!all(dplyr::between(pcts, 0, 1))) {
        stop("second value column cell is not a percentage.")
      }

      if (!is.null(fraction)) {
        # avoid problems with FALSE for 0.05 >= 0.05
        check_pcts <- pcts >= fraction |
          vapply(
            pcts,
            function(x) {
              isTRUE(all.equal(x, fraction))
            },
            TRUE
          )
      }

      if (!is.null(diff_from_control)) {
        # get control group from all columns tt (in case the columns selected would not include the control
        # group)
        colpaths0 <- col_paths(subset_cols(tt_all_cols, c(control)))
        cp0_nonrelrisk <- vapply(
          colpaths0,
          function(pth) {
            !any(grepl("rrisk", tolower(pth)))
          },
          FUN.VALUE = TRUE
        )
        colpaths0 <- colpaths0[cp0_nonrelrisk]

        if (length(colpaths0) != 1) {
          stop("control group spec does not result in single column.")
        } else {
          colpaths0 <- colpaths0[[1]]
          # get percent from control group
          pct0 <- cell_values(tt_all_cols, colpath = c(control))[[1]][2]

          if (!dplyr::between(pct0, 0, 1)) {
            stop("second value of control column cell is not a percentage.")
          }
        }

        # check if control group column was also present in main column selector
        colid0 <- which(sapply(colpaths, function(x) {
          all(x == colpaths0)
        }))

        pctdiffs <- pcts - pct0

        # exclude control column from this (would only be relevant if we want to check criteria on all columns
        # rather than any column)
        if (!identical(colid0, integer(0))) pctdiffs <- pctdiffs[-colid0]

        # if not only_more_often be equally strict on worse from control, better as control ie also select rows
        # where column is less often than control pct = 0.07 pct0 = 0.10 (diff = -0.03 )
        if (!only_more_often) pctdiffs <- abs(pctdiffs)

        # avoid problems with FALSE for 0.02 >= 0.02
        check_diffpcts <- pctdiffs >= diff_from_control |
          vapply(
            pctdiffs,
            function(x) {
              isTRUE(all.equal(x, diff_from_control))
            },
            TRUE
          )
      }

      # final step to check if row should be kept in table
      if (!is.null(fraction) && is.null(diff_from_control)) {
        # keep row in table if any column pct above threshold
        keep <- any(check_pcts)
      } else if ((!is.null(fraction) && !is.null(diff_from_control))) {
        # if any column pct above threshold AND any diff pct above threshold note any is used in both
        # expressions separately situation pct = 0.04 pct0 = 0.06 should be kept (fraction = 0.05, abs(diff
        # control) = 0.02) this problem only arises in the non-default situation when only_more_often is FALSE
        # (ie when column pct is less often than control) this would not be the case if we would any(check_pcts
        # & check_diffpcts) as 0.04 is below fraction
        keep <- any(check_pcts) && any(check_diffpcts)
      } else if ((is.null(fraction) && !is.null(diff_from_control))) {
        keep <- any(check_diffpcts)
      }

      # pruning function should return TRUE if row has to be removed, ie opposite of keep
      remove <- !keep
    }

    return(remove)
  }
}

lst_slicer <- function(lst, ind, type) {
  vapply(lst, `[[`, i = ind, type)
}

#' @name remove_rows
#'
#' @title
#' Pruning function to remove specific rows of a table regardless of counts
#' @description
#' This function will remove all rows of a table based on the row text
#' provided by the user.
#' @param  removerowtext  define a text string for which any row with row text will be removed.
#' @param reg_expr Apply removerowtext as a regular expression (grepl with fixed = TRUE)
#' @export
#' @rdname remove_rows
#'
#'
#' @examples
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   TRT01P = c(
#'     'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB', 'Placebo',
#'     'Placebo', 'Placebo', 'ARMA', 'ARMB'
#'   ),
#'   Category = c(
#'     'Cat 1', 'Cat 2', 'Cat 1', 'Unknown', 'Cat 2',
#'     'Cat 1', 'Unknown', 'Cat 1', 'Cat 2', 'Cat 1'
#'   ),
#'   SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
#'   PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
#' )
#'
#' ADSL <- ADSL |>
#'   dplyr::mutate(TRT01P = as.factor(TRT01P))
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT01P") |>
#'
#'   analyze(
#'     "Category",
#'     afun = a_freq_j,
#'     extra_args = list(.stats = "count_unique_fraction")
#'   )
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#'
#' # use pruning function to prune rows where category is Unknown
#' result <- prune_table(result, prune_func = remove_rows(removerowtext = 'Unknown'))
#'
#' result
#' @aliases remove_rows
#' @returns function that can be utilized as pruning function in prune_table
#'
remove_rows <- function(removerowtext = NULL, reg_expr = FALSE) {
  function(tt) {
    if (!methods::is(tt, "TableRow") || methods::is(tt, "LabelRow")) {
      return(FALSE)
    }

    ret <- FALSE
    if (!is.null(removerowtext)) {
      if (!reg_expr) {
        ret <- obj_label(tt) %in% removerowtext
      } else {
        ret <- any(sapply(removerowtext, function(x) {
          grepl(x, obj_label(tt), fixed = TRUE)
        }))
      }
    }

    ret
  }
}

#' @name keep_non_null_rows
#'
#' @title Pruning Function to accommodate removal of completely NULL rows within a table
#'
#' @description
#' Condition function on individual analysis rows. Flag as FALSE when all
#' columns are NULL, as then the row should not be kept. To be utilized as a
#' row_condition in function tern::keep_rows
#'
#' @param  tr      table tree object
#' @export
#'
#'
#' @examples
#'
#' library(dplyr)
#'
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
#'     'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
#'   ),
#'   TRT01P = c(
#'     'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB', 'Placebo',
#'     'Placebo', 'Placebo', 'ARMA', 'ARMB'
#'   ),
#'   AGE = c(34, 56, 75, 81, 45, 75, 48, 19, 32, 31),
#'   SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
#'   PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
#' )
#'
#' ADSL <- ADSL |>
#'   mutate(TRT01P = as.factor(TRT01P))
#'
#' create_blank_line <- function(x) {
#'   list(
#'     'Mean' = rcell(mean(x), format = 'xx.x'),
#'     ' ' = rcell(NULL),
#'     'Max' = rcell(max(x))
#'   )
#' }
#'
#' lyt <- basic_table() |>
#'   split_cols_by('TRT01P') |>
#'   analyze('AGE', afun = create_blank_line)
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#' # use pruning function to prune rows where category is Unknown
#' result <- prune_table(result, prune_func = tern::keep_rows(keep_non_null_rows))
#'
#' result
#' @rdname keep_non_null_rows
#' @returns a function that can be utilized as a row_condition in the tern::keep_rows function
#'
keep_non_null_rows <- function(tr) {
  if (methods::is(tr, "DataRow")) {
    r_cellvalue_null <- unlist(lapply(cell_values(tr), is.null))
    check <- all(r_cellvalue_null)

    ### if check TRUE (all cell values NULL -- need to return FALSE as need to remove)
    ret <- !check
  } else {
    ret <- TRUE
  }
  ret
}

#' Analysis and Content Summary Function Producing Blank Line
#'
#' @inheritParams proposal_argument_convention
#'
#' @keywords internal
ac_blank_line <- function(df, labelstr = "") {
  in_rows(.list = NA_real_, .labels = labelstr, .formats = "xx", .format_na_strs = "")
}

#' Insertion of Blank Lines in a Layout
#'
#' @inheritParams proposal_argument_convention
#'
#' @description This is a hack for `rtables` in order to be able to add row gaps,
#' i.e. blank lines.
#' In particular, by default this function needs to maintain a global state for avoiding
#' duplicate table names. The global state variable is hidden by using
#' a dot in front of its name. However, this likely won't work with parallelisation across
#' multiple threads and also causes non-reproducibility of the resulting `rtables`
#' object. Therefore also a custom table name can be used.
#'
#' @return The modified layout now including a blank line after the current
#'   row content.
#' @export
#'
#' @examples
#' ADSL <- ex_adsl
#'
#' lyt <- basic_table() |>
#'   split_cols_by('ARM') |>
#'   split_rows_by('STRATA1') |>
#'   analyze(vars = 'AGE', afun = function(x) {
#'     in_rows(
#'       'Mean (sd)' = rcell(c(mean(x), sd(x)), format = 'xx.xx (xx.xx)')
#'     )
#'   }) |>
#'   insert_blank_line() |>
#'   analyze(vars = 'AGE', table_names = 'AGE_Range', afun = function(x) {
#'     in_rows(
#'       'Range' = rcell(range(x), format = 'xx.xx - xx.xx')
#'     )
#'   })
#' build_table(lyt, ADSL)
insert_blank_line <- function(lyt, table_names = NULL) {
  varnames_rows <- vars_in_layout(lyt@row_layout)
  checkmate::assert_character(varnames_rows, min.len = 1L)
  last_varname_rows <- utils::tail(varnames_rows, 1L)

  this_table_name <- if (is.null(table_names)) {
    default_table_name <- paste0(".post_", last_varname_rows, "_blank")

    # A named list for tracking table names and counts
    table_count <- getOption("junco.insert_blank_line")

    new_count <- if (default_table_name %in% names(table_count)) {
      table_count[[default_table_name]] + 1
    } else {
      1
    }

    table_count[[default_table_name]] <- new_count
    options(junco.insert_blank_line = table_count)

    paste(default_table_name, new_count, sep = "_")
  } else {
    checkmate::assert_string(table_names, min.chars = 1L)
    table_names
  }

  analyze(
    lyt,
    vars = last_varname_rows,
    afun = ac_blank_line,
    show_labels = "hidden",
    table_names = this_table_name
  )
}

#' @name jjcs_num_formats
#'
#' @title Numeric Formatting Function
#'
#' @description
#' Formatting setter for selected numerical statistics
#'
#' @param d precision of individual values
#' @param cap cap to numerical precision (d > cap -- will use precision as if cap was specified as precision)
#'
#' @return list:
#'  - fmt : named vector with formatting function (jjcsformat_xx) for numerical stats: range, median, mean_sd, sd
#'  - spec : named vector with formatting specifications for numerical stats: range, median, mean_sd, sd
#' @export
#' @examples # P1_precision <- jjcs_num_formats(d=0)$fmt
# jjcs_num_formats(2)$fmt jjcs_num_formats(2)$specs
jjcs_num_formats <- function(d, cap = 4) {
  fmt_xx <- function(d, cap) {
    prec <- NULL
    ### report as is
    if (is.na(d)) {
      return("xx")
    }
    checkmate::assertCount(d)

    ### set a cap to number of decimal precision
    d <- min(d, cap)
    if (d > 0) prec <- paste0(prec, paste0(rep("x", d), collapse = ""))
    if (d >= 0) prec <- paste0("xx.", prec)

    return(prec)
  }

  fmt_rng <- function(d, cap) {
    prec <- fmt_xx(d, cap = cap)
    fmt <- list()
    fmt$spec <- paste0(prec, ", ", prec)
    fmt$fmt <- jjcsformat_xx(fmt$spec)

    return(fmt)
  }

  fmt_median <- function(d, cap) {
    prec <- fmt_xx(d, cap = cap)
    fmt <- list()
    fmt$spec <- prec
    fmt$fmt <- jjcsformat_xx(fmt$spec)
    return(fmt)
  }

  fmt_meansd <- function(d, cap) {
    prec1 <- fmt_xx(d, cap = cap)
    prec2 <- fmt_xx(d + 1, cap = cap + 1)
    fmt <- list()
    fmt$spec <- paste0(prec1, " (", prec2, ")")
    fmt$fmt <- jjcsformat_xx(fmt$spec)
    return(fmt)
  }
  fmt_sd <- function(d, cap) {
    prec <- fmt_xx(d, cap)
    fmt <- list()
    fmt$spec <- prec
    fmt$fmt <- jjcsformat_xx(fmt$spec)
    return(fmt)
  }

  ## apply formats for each of the stats with appropriate d and cap
  xfmt_rng <- fmt_rng(d, cap = cap)
  xfmt_meansd <- fmt_meansd(d + 1, cap = cap + 1)
  xfmt_sd <- fmt_sd(d + 2, cap = cap + 2)
  xfmt_median <- fmt_median(d + 1, cap = cap + 1)

  fmts <- list()

  fmts$fmt <- c(range = xfmt_rng$fmt, mean_sd = xfmt_meansd$fmt, sd = xfmt_sd$fmt, median = xfmt_median$fmt)

  fmts$spec <- c(range = xfmt_rng$spec, mean_sd = xfmt_meansd$spec, sd = xfmt_sd$spec, median = xfmt_median$spec)

  return(fmts)
}

#' @keywords internal
memoised_fit_mmrm <- memoise::memoise(fit_mmrm_j)

#' Helper Function to Fit the MMRM and Return LS Mean Estimates and Contrasts
#'
#' @inheritParams proposal_argument_convention
#' @param df_parent (`data.frame`)\cr data set containing all analysis variables
#'   from all visits and arms.
#' @param ref_arm_level (`string`)\cr the reference arm which should be compared
#'   against.
#' @param ref_visit_levels (`character`)\cr the reference visits which should not
#'   be included in the model fit.
#' @param ... additional options passed to [fit_mmrm_j()].
#'
#' @return The resulting estimates and contrasts LS means as returned by
#'   [tidy.tern_model()].
#' @keywords internal
h_summarize_mmrm <- function(.var, df_parent, variables, ref_arm_level, ref_visit_levels, ...) {
  checkmate::assert_string(.var)
  variables$response <- .var

  checkmate::assert_string(ref_arm_level)
  arm_levels <- levels(df_parent[[variables$arm]])
  if (arm_levels[1L] != ref_arm_level) {
    checkmate::assert_subset(ref_arm_level, arm_levels[-1L])
    df_parent[[variables$arm]] <- stats::relevel(df_parent[[variables$arm]], ref = ref_arm_level)
  }
  checkmate::assert_character(ref_visit_levels)
  in_ref_visits <- df_parent[[variables$visit]] %in% ref_visit_levels
  df_parent <- df_parent[!in_ref_visits, , drop = FALSE]
  checkmate::assert_true(nrow(df_parent) > 1)
  new_levels <- setdiff(levels(df_parent[[variables$visit]]), ref_visit_levels)
  df_parent[[variables$visit]] <- factor(df_parent[[variables$visit]], levels = new_levels)
  mod_fit <- memoised_fit_mmrm(vars = variables, data = df_parent, ...)
  tidy(mod_fit)
}

#' Dynamic tabulation of MMRM results with tables
#'
#' @description `r lifecycle::badge('stable')`
#'
#' These functions can be used to produce tables for MMRM results, within
#' tables which are split by arms and visits. This is helpful when higher-level
#' row splits are needed (e.g. splits by parameter or subgroup).
#'
#' @name summarize_mmrm
#' @examples
#' set.seed(123)
#' longdat <- data.frame(
#'   ID = rep(DM$ID, 5),
#'   AVAL = c(
#'     rep(0, nrow(DM)),
#'     rnorm(n = nrow(DM) * 4)
#'   ),
#'   VISIT = factor(rep(paste0('V', 0:4), each = nrow(DM)))
#' ) |>
#'   dplyr::inner_join(DM, by = 'ID')
#'
NULL

#' @describeIn summarize_mmrm Statistics function which is extracting estimates,
#'   not including any results when in the reference visit, and only showing LS mean
#'   estimates when in the reference arm and not in reference visit. It uses
#'   [s_lsmeans()] for the final processing.
#'
#' @inheritParams proposal_argument_convention
#' @param ref_levels (`list`)\cr with `visit` and `arm` reference levels.
#' @param ... eventually passed to [fit_mmrm_j()] via [h_summarize_mmrm()].
#' @export
s_summarize_mmrm <- function(
  df,
  .var,
  variables,
  ref_levels,
  .spl_context,
  alternative = c("two.sided", "less", "greater"),
  show_relative = c("reduction", "increase"),
  ...
) {
  alternative <- match.arg(alternative)

  checkmate::assert_list(variables, names = "unique")
  visit_var <- variables$visit
  arm_var <- variables$arm

  checkmate::assert_list(ref_levels, names = "unique")
  checkmate::assert_subset(c(visit_var, arm_var), names(ref_levels))
  ref_visits <- ref_levels[[visit_var]]
  ref_arm <- ref_levels[[arm_var]]
  checkmate::assert_string(ref_arm)

  current_visit <- as.character(unique(df[[visit_var]]))
  current_arm <- as.character(unique(df[[arm_var]]))
  checkmate::assert_string(current_visit)
  checkmate::assert_string(current_arm)

  in_ref_visits <- current_visit %in% ref_visits
  in_ref_arm <- current_arm == ref_arm

  if (in_ref_visits) {
    ## this is returned
    list(
      n = NULL,
      adj_mean_se = NULL,
      adj_mean_ci = NULL,
      adj_mean_est_ci = NULL,
      diff_mean_se = NULL,
      diff_mean_ci = NULL,
      diff_mean_est_ci = NULL,
      change = NULL,
      p_value = NULL
    )
  } else { # non ref visit
    n_splits <- nrow(.spl_context)

    # Check that the current row split is by the visit variable.
    current_split_var <- .spl_context[n_splits, "split"]
    checkmate::assert_true(identical(current_split_var, visit_var))

    # Then take the data frame with all visits and fit the MMRM on it.
    df_parent <- .spl_context[n_splits - 1, "full_parent_df"][[1]]
    lsm_df <- h_summarize_mmrm(
      .var = .var,
      df_parent = df_parent,
      variables = variables,
      ref_arm_level = ref_arm,
      ref_visit_levels = ref_visits,
      ...
    )

    # Subset to the current table cell we are looking at.
    matches_visit <- lsm_df[[visit_var]] == current_visit
    matches_arm <- lsm_df[[arm_var]] == current_arm
    matches_both <- which(matches_visit & matches_arm)
    checkmate::assert_int(matches_both)

    s_lsmeans(
      lsm_df[matches_both, ],
      .in_ref_col = in_ref_arm,
      alternative = alternative,
      show_relative = show_relative
    )
  } # end ref visits if/else
}

#' @describeIn summarize_mmrm Formatted analysis function which is used as `afun`.
#'
#' @return
#' * `a_summarize_mmrm()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' basic_table() |>
#'   split_rows_by('VISIT') |>
#'   split_cols_by('ARM') |>
#'   analyze(
#'     vars = 'AVAL',
#'     afun = a_summarize_mmrm,
#'     na_str = tern::default_na_str(),
#'     show_labels = "hidden",
#'     extra_args = list(
#'       variables = list(
#'         covariates = c('AGE'),
#'         id = 'ID',
#'         arm = 'ARM',
#'         visit = 'VISIT'
#'       ),
#'       conf_level = 0.9,
#'       cor_struct = 'toeplitz',
#'       ref_levels = list(VISIT = 'V0', ARM = 'B: Placebo')
#'     )
#'   ) |>
#'   build_table(longdat) |>
#'   prune_table(all_zero)
#' @export
a_summarize_mmrm <- function(
  df,
  .var,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_summarize_mmrm,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .var = .var, .spl_context = list(.spl_context), dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "summarize_mmrm",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Split Function Factory for the Response Tables (RESP01)
#'
#' The main purpose here is to have a column dependent split into either comparative
#' statistic (relative risk or odds ratio with p-value) in the 'Overall' column,
#' and count proportions and corresponding confidence intervals in the other treatment
#' arm columns.
#'
#' @inheritParams proposal_argument_convention
#' @param method (`string`)\cr which method to use for the comparative statistics.
#'
#' @return A split function for use in the response table RESP01 and similar ones.
#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
#'   post-processing function.
#' @export
#'
#' @examples
#' split_fun <- resp01_split_fun_fct(
#'   method = "or_cmh",
#'   conf_level = 0.95
#' )
resp01_split_fun_fct <- function(method = c("rr", "or_logistic", "or_cmh"), conf_level) {
  method <- match.arg(method)
  (assert_proportion_value)(conf_level)

  post_fun <- function(ret, spl, fulldf, .spl_context) {
    all_expr <- expression(TRUE)
    # Here check if we are in 'Overall' column or not.
    this_col <- .spl_context[nrow(.spl_context), "value"][[1]]
    in_overall <- this_col == "Overall"
    # Accordingly, return left and right column labels and value identifiers.
    if (in_overall) {
      # In the Overall column, we want the comparison statistic and corresponding p-value.
      comp_stat_name <- if (method == "rr") "Relative Risk" else "Odds Ratio"
      short_split_result(
        comp_stat_ci = paste0(comp_stat_name, " (", f_conf_level(conf_level), ")~[super a]"),
        pval = "p-value~[super b]",
        fulldf = fulldf
      )
    } else {
      # In the treatment arm columns, we want counts and CI for proportions.
      short_split_result(
        count_prop = "n (%)",
        prop_ci = paste0(f_conf_level(conf_level), " for %"),
        fulldf = fulldf
      )
    }
  }
  make_split_fun(post = list(post_fun))
}

#' Content Row Function for Counts of Subgroups in Response Tables (RESP01)
#'
#' @inheritParams proposal_argument_convention
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param label_fstr (`string`)\cr format string for the label.
#'
#' @return The correct [rtables::in_rows()] result.
#' @export
#'
#' @examples
#' fake_spl_context <- data.frame(
#'   cur_col_split_val = I(list(c(ARM = "A: Drug X", count_prop = "count_prop")))
#' )
#' resp01_counts_cfun(
#'   df = DM,
#'   labelstr = "Blue",
#'   .spl_context = fake_spl_context,
#'   .alt_df = DM,
#'   label_fstr = "Color: %s"
#' )
resp01_counts_cfun <- function(df, labelstr, .spl_context, .alt_df, label_fstr) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  if (this_col_split[1] != "Overall" && this_col_split[2] == "count_prop") {
    in_rows(nrow(.alt_df), .formats = "xx", .labels = sprintf(label_fstr, labelstr))
  } else {
    NULL
  }
}

#' Formatted Analysis Function for Comparative Statistic in Response Tables (RESP01)
#'
#' This function applies to a `logical` column called `.var` from `df`.
#' The response proportion is compared between the treatment arms identified
#' by column `arm`.
#'
#' @inheritParams proposal_argument_convention
#' @param include (`flag`)\cr whether to include the results for this variable.
#' @param arm (`string`)\cr column name in the data frame that identifies the treatment arms.
#' @param formats (`list`)\cr containing formats for `comp_stat_ci` and `pval`.
#' @param methods (`list`)\cr containing methods for comparative statistics. The element `comp_stat_ci` can be
#'   'rr' (relative risk), 'or_cmh' (odds ratio with CMH estimation and p-value) or 'or_logistic' (odds ratio
#'   estimated by conditional or standard logistic regression). The element `pval` can be 'fisher' (Fisher's
#'   exact test) or 'chisq' (chi-square test), only used when using unstratified analyses with 'or_logistic'.
#' @param stat (`string`)\cr the statistic to return, either `comp_stat_ci`
#'   or `pval`.
#'
#' @return The formatted result as [rtables::rcell()].
#' @seealso [resp01_a_comp_stat_factor()] for the `factor` equivalent.
#' @export
#'
#' @examples
#' dm <- droplevels(subset(formatters::DM, SEX %in% c("F", "M")))
#' dm$RESP <- as.logical(sample(c(TRUE, FALSE), size = nrow(DM), replace = TRUE))
#'
#' resp01_a_comp_stat_logical(
#'   dm,
#'   .var = "RESP",
#'   conf_level = 0.9,
#'   include = TRUE,
#'   arm = "SEX",
#'   strata = "RACE",
#'   stat = "comp_stat_ci",
#'   method = list(comp_stat_ci = "or_cmh"),
#'   formats = list(
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
resp01_a_comp_stat_logical <- function(df,
                                       .var,
                                       conf_level,
                                       include,
                                       arm,
                                       strata,
                                       formats,
                                       methods,
                                       stat = c("comp_stat_ci", "pval")) {
  checkmate::assert_logical(df[[.var]])
  checkmate::assert_factor(df[[arm]], n.levels = 2L)
  checkmate::assert_flag(include)
  stat <- match.arg(stat)

  if (include) {
    checkmate::assert_list(methods)
    checkmate::assert_subset(methods$comp_stat_ci, c("rr", "or_cmh", "or_logistic"))

    df_by <- split(df, f = df[[arm]])
    this_df <- df_by[[1]]
    this_ref_group <- df_by[[2]]

    this_res <- if (methods$comp_stat_ci == "rr") {
      # Stratified CMH test for point estimate and p-value, and Wald statistic for the confidence interval
      s_res <- s_relative_risk(
        this_df,
        .var = .var,
        .ref_group = this_ref_group,
        .in_ref_col = FALSE,
        variables = list(strata = strata),
        conf_level = conf_level
      )
      list(comp_stat_ci = s_res$rel_risk_ci, pval = s_res$pval)
    } else if (methods$comp_stat_ci == "or_logistic") {
      # Odds Ratio Variant 1: (Conditional/Standard) Logistic regression for odds ratio point estimate and
      # confidence interval.
      s_res <- s_odds_ratio_j(
        this_df,
        .var = .var,
        .ref_group = this_ref_group,
        .in_ref_col = FALSE,
        .df_row = rbind(this_df, this_ref_group),
        variables = list(arm = arm, strata = strata),
        conf_level = conf_level,
        method = "exact" # Only used if strata are present.
      )
      pval <- if (is.null(strata)) {
        checkmate::assert_subset(methods$pval, c("fisher", "chisq"))

        # If not stratified, then the p-value can come either from Fisher's exact or chi-square test.
        p_res <- s_test_proportion_diff(
          this_df,
          .var = .var,
          .ref_group = this_ref_group,
          .in_ref_col = FALSE,
          method = methods$pval
        )
        p_res$pval
      } else {
        s_res$pval
      }
      list(comp_stat_ci = s_res$or_ci, pval = pval)
    } else if (methods$comp_stat_ci == "or_cmh") {
      # Odds Ratio Variant 2: Stratified CMH test for odds ratio point estimate and confidence interval and
      # corresponding CMH test p-value.
      s_res <- s_odds_ratio_j(
        this_df,
        .var = .var,
        .ref_group = this_ref_group,
        .in_ref_col = FALSE,
        .df_row = rbind(this_df, this_ref_group),
        variables = list(arm = arm, strata = strata),
        conf_level = conf_level,
        method = "cmh"
      )
      list(comp_stat_ci = s_res$or_ci, pval = s_res$pval)
    }
    rcell(this_res[[stat]], format = formats[[stat]])
  } else {
    NULL
  }
}

#' Formatted Analysis Function for Comparative Statistic in Response Tables (RESP01)
#'
#' This function applies to a `factor` column called `.var` from `df`.
#'
#' @inheritParams proposal_argument_convention
#' @param include (`character`)\cr for which factor levels to include the comparison
#'   statistic results.
#' @param \dots see [resp01_a_comp_stat_logical()] for additional required arguments.
#'
#' @return The formatted result as [rtables::rcell()].
#' @export
#'
#' @examples
#' dm <- droplevels(subset(formatters::DM, SEX %in% c("F", "M")))
#'
#' resp01_a_comp_stat_factor(
#'   dm,
#'   .var = "COUNTRY",
#'   conf_level = 0.9,
#'   include = c("USA", "CHN"),
#'   arm = "SEX",
#'   strata = "RACE",
#'   stat = "comp_stat_ci",
#'   method = list(comp_stat_ci = "or_cmh"),
#'   formats = list(
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
resp01_a_comp_stat_factor <- function(df,
                                      .var,
                                      include,
                                      ...) {
  checkmate::assert_factor(df[[.var]])
  checkmate::assert_character(include, null.ok = TRUE)
  checkmate::assert_subset(x = include, choices = levels(df[[.var]]))

  design_df <- as.data.frame(h_get_design_mat(df, .var))

  res <- sapply(X = levels(df[[.var]]), simplify = FALSE, FUN = function(lvl) {
    df[[.var]] <- design_df[[lvl]]
    resp01_a_comp_stat_logical(df = df, .var = .var, include = lvl %in% include, ...)
  })
  in_rows(.list = res, .labels = levels(df[[.var]]))
}

#' Formatted Analysis and Content Summary Function for Response Tables (RESP01)
#'
#' This function applies to both `factor` and `logical` columns called
#' `.var` from `df`. Depending on the position in the split, it returns the
#' right formatted results for the RESP01 and related layouts.
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams resp01_a_comp_stat_logical
#' @param include_comp (`character` or `flag`)\cr whether to include comparative
#'   statistic results, either `character` for factors or `flag` for logicals.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param arm (`string`)\cr column name in the data frame that identifies the treatment arms.
#' @param label (`string`)\cr only for logicals, which label to use. (For factors, the
#'   labels are the factor levels.)
#' @param formats (`list`)\cr containing formats for `prop_ci`, `comp_stat_ci`
#'   and `pval`.
#' @param methods (`list`)\cr containing methods for comparative statistics. The element `comp_stat_ci` can be
#'   'rr' (relative risk), 'or_cmh' (odds ratio with CMH estimation and p-value) or 'or_logistic' (odds ratio
#'   estimated by conditional or standard logistic regression). The element `pval` can be 'fisher' (Fisher's
#'   exact test) or 'chisq' (chi-square test), only used when using unstratified analyses with 'or_logistic'.
#'   The element `prop_ci` specifies the method for proportion confidence interval calculation.
#'
#' @return The formatted result as [rtables::in_rows()] result.
#' @export
#'
#' @examples
#' fake_spl_context <- data.frame(
#'   cur_col_split_val = I(list(c(ARM = "A: Drug X", count_prop = "count_prop")))
#' )
#' dm <- droplevels(subset(DM, SEX %in% c("F", "M")))
#' resp01_acfun(
#'   dm,
#'   .alt_df = dm,
#'   .var = "COUNTRY",
#'   .spl_context = fake_spl_context,
#'   conf_level = 0.9,
#'   include_comp = c("USA", "CHN"),
#'   arm = "SEX",
#'   strata = "RACE",
#'   methods = list(
#'     comp_stat_ci = "or_cmh",
#'     pval = "",
#'     prop_ci = "wald"
#'   ),
#'   formats = list(
#'     prop_ci = jjcsformat_xx("xx.% - xx.%"),
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
#' fake_spl_context2 <- data.frame(
#'   cur_col_split_val = I(list(c(ARM = "Overall", comp_stat_ci = "comp_stat_ci")))
#' )
#' resp01_acfun(
#'   dm,
#'   .alt_df = dm,
#'   .var = "COUNTRY",
#'   .spl_context = fake_spl_context2,
#'   conf_level = 0.9,
#'   include_comp = c("USA", "CHN"),
#'   arm = "SEX",
#'   strata = "RACE",
#'   methods = list(
#'     comp_stat_ci = "or_cmh",
#'     pval = "",
#'     prop_ci = "wald"
#'   ),
#'   formats = list(
#'     prop_ci = jjcsformat_xx("xx.% - xx.%"),
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
resp01_acfun <- function(df,
                         labelstr = NULL,
                         label = NULL,
                         .var,
                         .spl_context,
                         include_comp,
                         .alt_df,
                         conf_level,
                         arm,
                         strata,
                         formats,
                         methods) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  x <- df[[.var]]
  is_factor <- is.factor(x)
  res <- if (this_col_split[1] != "Overall") {
    if (this_col_split[2] == "count_prop") {
      if (is_factor) {
        s_proportion_factor(x, .alt_df = .alt_df)
      } else {
        s_proportion_logical(x, .alt_df = .alt_df)$n_prop
      }
    } else {
      checkmate::assert_true(this_col_split[2] == "prop_ci")
      if (is_factor) {
        a_proportion_ci_factor(
          df,
          .var = .var,
          .alt_df = .alt_df,
          conf_level = conf_level,
          formats = formats,
          method = methods$prop_ci
        )
      } else {
        a_proportion_ci_logical(
          x,
          .alt_df = .alt_df,
          conf_level = conf_level,
          formats = formats,
          method = methods$prop_ci
        )
      }
    }
  } else {
    checkmate::assert_true(this_col_split[1] == "Overall")
    if (is_factor) {
      resp01_a_comp_stat_factor(
        df,
        .var = .var,
        conf_level = conf_level,
        include = include_comp,
        arm = arm,
        strata = strata,
        stat = this_col_split[2],
        formats = formats,
        methods = methods
      )
    } else {
      resp01_a_comp_stat_logical(
        df,
        .var = .var,
        conf_level = conf_level,
        include = include_comp,
        arm = arm,
        strata = strata,
        stat = this_col_split[2],
        formats = formats,
        methods = methods
      )
    }
  }
  if (is_factor) {
    res
  } else {
    if (!is.null(labelstr)) {
      label <- labelstr
    }
    in_rows(res, .labels = label)
  }
}

#' Obtain Reference Information for a Global Reference Group
#'
#' This helper function can be used in custom analysis functions, by passing
#' an extra argument `ref_path` which defines a global reference group by
#' the corresponding column split hierarchy levels.
#'
#' @param ref_path (`character`)\cr reference group specification as an `rtables`
#'   `colpath`, see details.
#' @param .spl_context see [rtables::spl_context].
#' @param .var the variable being analyzed, see [rtables::additional_fun_params].
#'
#' @return A list with `ref_group` and `in_ref_col`, which can be used as
#'   `.ref_group` and `.in_ref_col` as if being directly passed to an analysis
#'   function by `rtables`, see [rtables::additional_fun_params].
#'
#' @details
#' The reference group is specified in `colpath` hierarchical fashion in `ref_path`:
#' The first column split variable is the first element, and the level to use is the
#' second element. It continues until the last column split variable with last
#' level to use.
#' Note that depending on `.var`, either a `data.frame` (if `.var` is `NULL`) or
#' a vector (otherwise) is returned. This allows usage for analysis functions with
#' `df` and `x` arguments, respectively.
#'
#' @export
#'
#' @examples
#' dm <- DM
#' dm$colspan_trt <- factor(
#'   ifelse(dm$ARM == 'B: Placebo', ' ', 'Active Study Agent'),
#'   levels = c('Active Study Agent', ' ')
#' )
#' colspan_trt_map <- create_colspan_map(
#'   dm,
#'   non_active_grp = 'B: Placebo',
#'   non_active_grp_span_lbl = ' ',
#'   active_grp_span_lbl = 'Active Study Agent',
#'   colspan_var = 'colspan_trt',
#'   trt_var = 'ARM'
#' )
#'
#' # A standard analysis function which uses a reference group.
#' standard_afun <- function(x, .ref_group, .in_ref_col) {
#'   in_rows(
#'     'Difference of Averages' = non_ref_rcell(
#'       mean(x) - mean(.ref_group),
#'       is_ref = .in_ref_col,
#'       format = 'xx.xx'
#'     )
#'   )
#' }
#'
#' # The custom analysis function which can work with a global reference group.
#' result_afun <- function(x, ref_path, .spl_context, .var) {
#'   ref <- get_ref_info(ref_path, .spl_context, .var)
#'   standard_afun(x, .ref_group = ref$ref_group, .in_ref_col = ref$in_ref_col)
#' }
#'
#' # Define the global reference group colpath.
#' ref_path <- c('colspan_trt', ' ', 'ARM', 'B: Placebo')
#'
#' lyt <- basic_table() |>
#'   split_cols_by(
#'     'colspan_trt',
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by('ARM') |>
#'   analyze(
#'     'AGE',
#'     # Here we pass the global reference group colpath.
#'     extra_args = list(ref_path = ref_path),
#'     afun = result_afun
#'   )
#'
#' build_table(lyt, dm)
get_ref_info <- function(ref_path, .spl_context, .var = NULL) {
  checkmate::check_character(ref_path, min.len = 2L, names = "unnamed")
  checkmate::assert_true(length(ref_path) %% 2 == 0) # Even number of elements in ref_path.
  leaf_spl_context <- .spl_context[nrow(.spl_context), ]
  full_df <- leaf_spl_context$full_parent_df[[1]]
  level_indices <- seq(from = 2L, to = length(ref_path), by = 2L)
  ref_group_string <- paste(ref_path[level_indices], collapse = ".")
  row_in_ref_group <- leaf_spl_context[[ref_group_string]][[1]]
  ref_group <- full_df[row_in_ref_group, ]
  if (!is.null(.var)) {
    ref_group <- ref_group[[.var]]
  }
  colvars_indices <- seq(from = 1L, to = length(ref_path) - 1L, by = 2L)
  checkmate::assert_true(identical(leaf_spl_context$cur_col_split[[1]], ref_path[colvars_indices]))
  in_ref_col <- identical(leaf_spl_context$cur_col_split_val[[1]], ref_path[level_indices])
  list(ref_group = ref_group, in_ref_col = in_ref_col)
}

#' Workaround statistics function to time point survival estimate with CI
#'
#' This is a workaround for [tern::s_surv_timepoint()], which adds a statistic
#' containing the time point specific survival estimate together with the
#' confidence interval.
#'
#' @inheritParams proposal_argument_convention
#'
#' @name event_free
#' @order 1
NULL

#' @describeIn event_free Statistics function which works like [tern::s_surv_timepoint()],
#'   the difference is that it returns the additional statistic `event_free_ci`.
#' @param time_point (`numeric`)\cr time point at which to estimate survival.
#' @param time_unit (`string`)\cr unit of time for the time point.
#' @param percent (`flag`)\cr whether to return in percent or not.
#' @export
#'
#' @examples
#' adtte_f <- tern::tern_ex_adtte |>
#'   dplyr::filter(PARAMCD == "OS") |>
#'   dplyr::mutate(
#'     AVAL = tern::day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#'
#' s_event_free(
#'   df = adtte_f,
#'   .var = 'AVAL',
#'   time_point = 6,
#'   is_event = 'is_event',
#'   time_unit = 'month'
#' )
#' @order 3
s_event_free <- function(
  df,
  .var,
  time_point,
  time_unit,
  is_event,
  percent = FALSE,
  control = control_surv_timepoint()
) {
  checkmate::assert_string(time_unit, min.chars = 1L)
  start <- s_surv_timepoint(
    df = df,
    .var = .var,
    time_point = time_point,
    is_event = is_event,
    control = control
  )
  rates <- c(start$event_free_rate, start$rate_ci)
  if (!percent) rates <- rates / 100
  unit_label <- if (percent) "(%) " else ""
  c(
    start,
    list(
      event_free_ci = with_label(
        rates,
        paste0(
          time_point,
          "-",
          time_unit,
          " event-free rate ",
          unit_label,
          "(",
          obj_label(start$rate_ci),
          ")"
        )
      )
    )
  )
}

#' @describeIn event_free Formatted analysis function which is used as `afun`.
#'
#' @export
#' @order 2
#'
#' @examples
#' adtte_f <- tern::tern_ex_adtte |>
#'   dplyr::filter(PARAMCD == "OS") |>
#'   dplyr::mutate(
#'     AVAL = tern::day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#'
#' basic_table() |>
#'   split_cols_by(var = 'ARMCD') |>
#'   analyze(
#'     vars = 'AVAL',
#'     afun = a_event_free,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     extra_args = list(
#'       time_unit = 'week',
#'       time_point = 3,
#'       is_event = 'is_event'
#'     )
#'   ) |>
#'   build_table(df = adtte_f)
a_event_free <- function(df, .var, ..., .stats = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_event_free,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .var = .var, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "event_free",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' rm_other_facets_fact
#' @param nm character. names of facets to keep. all other facets will be
#' removed
#' @returns a function suitable for use within the `post` portion make_split_fun

rm_other_facets_fact <- function(nm) {
  function(ret, spl, .spl_context, fulldf) {
    keep <- which(names(ret$values) %in% nm)
    stopifnot(length(keep) > 0)
    # values already have subsetting expressions on them
    make_split_result(ret$values[keep], ret$datasplit[keep], ret$labels[keep])
  }
}

#' @name real_add_overall_facet
#'
#' @title Add Overall Facet
#'
#' @description
#' A function to help add an overall facet to your tables
#' @param name character(1). Name/virtual 'value' for the new facet
#' @param label character(1). label for the new facet
#' @note current add_overall_facet is bugged, can use that directly after it's fixed
#' https://github.com/insightsengineering/rtables/issues/768
#' @examples
#' # split_rows_by(
#' #   'AVALCAT1',
#' #   split_fun = make_split_fun(
#' #     post = list(real_add_overall_facet('Total', 'Total'))
#' #   ),
#' #   child_labels =  'hidden'
#' # )
#' @export
#' @returns function usable directly as a split function.
#'
real_add_overall_facet <- function(name, label) {
  function(ret, spl, .spl_context, fulldf) {
    add_to_split_result(
      ret,
      values = name,
      datasplit = stats::setNames(list(fulldf), name),
      labels = stats::setNames(label, name),
      subset_exprs = quote(TRUE)
    )
  }
}

#' @name make_combo_splitfun
#'
#' @title Split Function Helper
#'
#' @description
#' A function which aids the construction for users to create their own split function for combined columns
#' @param nm character(1). Name/virtual 'value' for the new facet
#' @param label character(1). label for the new facet
#' @param levels character or NULL. The levels to combine into the new facet,
#' or NULL, indicating the facet should include all incoming data.
#' @param rm_other_facets logical(1). Should facets other than the newly
#' created one be removed. Defaults to `TRUE`
#' @export
#' @returns function usable directly as a split function.
#' @examples # aesevall_spf <- make_combo_splitfun(nm = 'AESEV_ALL', label  = 'Any AE', levels = NULL)
#'
make_combo_splitfun <- function(nm, label = nm, levels = NULL, rm_other_facets = TRUE) {
  if (is.null(levels)) {
    fn <- real_add_overall_facet(name = nm, label = label)
  } else {
    fn <- add_combo_facet(name = nm, label = label, levels = levels)
  }
  if (rm_other_facets) {
    rmfun <- rm_other_facets_fact(nm)
  } else {
    rmfun <- NULL
  }
  make_split_fun(post = c(list(fn), if (rm_other_facets) list(rmfun)))
}

blank_regex <- "^[[:space:]]*$"

combine_nonblank <- function(name, label) {
  function(ret, spl, .spl_context, fulldf) {
    df <- fulldf[!grepl(blank_regex, fulldf[[spl_variable(spl)]]), ]
    add_to_split_result(
      ret,
      values = name,
      datasplit = stats::setNames(list(df), name),
      labels = stats::setNames(label, name)
    )
  }
}

rm_blank_levels <- function(df, spl, ...) {
  var <- spl_variable(spl)
  varvec <- df[[var]]
  oldlevs <- levels(varvec)
  newlevs <- oldlevs[!grepl(blank_regex, oldlevs)]
  df <- df[!grepl(blank_regex, varvec), ]
  df[[var]] <- factor(df[[var]], levels = newlevs)
  df
}


find_torm <- function(spl_ret, torm, torm_regex, keep_matches) {
  if (!is.null(torm)) {
    ans_lgl <- names(spl_ret$datasplit) %in% torm
  } else {
    ans_lgl <- grepl(torm_regex, names(spl_ret$datasplit))
  }
  if (keep_matches) {
    ans_lgl <- !ans_lgl
  }
  which(ans_lgl)
}

.check_rem_cond <- function(cond_str, cond_regex, spl_ctx, pos, type) {
  if (is.null(cond_str) && is.null(cond_regex)) {
    return(TRUE)
  }
  if (!is.null(cond_str) && !is.null(cond_regex)) {
    stop(
      "Got both ",
      paste(paste0(type, c("", "_regex")), collapse = " and "),
      ". Please specify at most one of these."
    )
  }
  ctx_data <- spl_ctx[[type]][pos]
  if (!is.null(cond_str)) {
    any(cond_str %in% ctx_data)
  } else {
    any(grepl(cond_regex, ctx_data))
  }
}

## handle support for NA and negative positions only called once but code is nicer with it factored out here
resolve_ancestor_pos <- function(anc_pos, numrows) {
  if (is.na(anc_pos)) {
    anc_pos <- seq_len(numrows)
  } else if (any(anc_pos < 0)) {
    if (!all(anc_pos < 0)) {
      stop("Got mix of negative and non-negative values for ancestor_pos; ", "this is not supported.")
    }
    ## direct parent is actually NROW(.spl_context) so avoid off-by-1 error with the + 1 here
    anc_pos <- numrows - (anc_pos + 1)
  }
  anc_pos
}

#' @name cond_rm_facets
#' @title Conditional Removal of Facets
#' @param facets character or NULL. Vector of facet names to be removed
#' if condition(s) are met
#' @param facets_regex character(1). Regular expression to identify facet
#' names to be removed if condition(s) are met.
#' @param ancestor_pos numeric(1). Row in spl_context to check the condition
#' within. E.g., 1 represents the first split, 2 represents the second split
#' nested within the first, etc. NA specifies that the conditions
#' should be checked at all split levels. Negative integers indicate position
#' counting back from the current one, e.g., -1 indicates the direct parent
#' (most recent split before this one). Negative and positive/NA positions
#' cannot be mixed.
#' @param split character(1) or NULL. If specified, name of the split
#' at position `ancestor_pos` must be identical to this value for
#' the removal condition to be met.
#' @param split_regex character(1) or NULL. If specified, a regular expression
#' the name of the split at position `ancestor_pos` must match for
#' the removal condition to be met. Cannot be specified at the same time
#' as `split`.
#' @param value character(1) or NULL. If specified, split (facet) value
#' at position `ancestor_pos` must be identical to this value for
#' removal condition to be met.
#' @param value_regex character(1) or NULL. If specified, a regular expression
#' the value of the split at position `ancestor_pos` must match for
#' the removal condition to be met. Cannot be specified at the same time
#' as `value`.
#' @param keep_matches logical(1). Given the specified condition is met,
#' should the facets removed be those matching `facets`/`facets_regex`
#' (`FALSE`, the default), or those *not* matching (`TRUE`).
#'
#' @details Facet removal occurs when the specified condition(s)
#' on the split(s) and or value(s) are met within at least one
#' of the split_context rows indicated by `ancestor_pos`; otherwise
#' the set of facets is returned unchanged.
#'
#' If facet removal is performed, either *all* facets which match `facets` (or
#' `facets_regex` will be removed ( the default `keep_matches == FALSE`
#'  case), or all *non-matching* facets will be removed (when
#'   `keep_matches_only == TRUE`).
#'
#' @note A degenerate table is likely to be returned if all facets
#' are removed.
#'
#' @returns a function suitable for use in `make_split_fun`'s
#' `post` argument which encodes the specified condition.
#' @export
#' @examples
#'
#' ## remove the 'A' facet if anywhere in the preceding
#' ## faceting, we had a split 'ARM' (splitting the ARM var)
#' ## with a value that matches 'Placeb' as a regex
#' rm_a_from_placebo <- cond_rm_facets(
#'   facets = 'A',
#'   ancestor_pos = NA,
#'   value_regex = 'Placeb',
#'   split = 'ARM'
#' )
#' mysplit <- make_split_fun(post = list(rm_a_from_placebo))
#'
#' lyt <- basic_table() |>
#'   split_cols_by('ARM') |>
#'   split_cols_by('STRATA1', split_fun = mysplit) |>
#'   analyze('AGE', mean, format = 'xx.x')
#' build_table(lyt, ex_adsl)
#'
#' rm_bc_from_combo <- cond_rm_facets(
#'   facets = c('B', 'C'),
#'   ancestor_pos = -1,
#'   value_regex = 'Combi'
#' )
#' mysplit2 <- make_split_fun(post = list(rm_bc_from_combo))
#'
#' lyt2 <- basic_table() |>
#'   split_cols_by('ARM') |>
#'   split_cols_by('STRATA1', split_fun = mysplit2) |>
#'   analyze('AGE', mean, format = 'xx.x')
#' tbl2 <- build_table(lyt2, ex_adsl)
#' tbl2
#' #
#' rm_bc_from_combo2 <- cond_rm_facets(
#'   facets_regex = '^A$',
#'   ancestor_pos = -1,
#'   value_regex = 'Combi',
#'   keep_matches = TRUE
#' )
#' mysplit3 <- make_split_fun(post = list(rm_bc_from_combo2))
#' #
#' lyt3 <- basic_table() |>
#'   split_cols_by('ARM') |>
#'   split_cols_by('STRATA1', split_fun = mysplit3) |>
#'   analyze('AGE', mean, format = 'xx.x')
#' tbl3 <- build_table(lyt3, ex_adsl)
#' ## column info carries around the split objects which
#' ## carry around their split_fun, which are different so
#' ## identical(tbl2, tbl3) will (expectedly) be FALSE
#' stopifnot(identical(cell_values(tbl2), cell_values(tbl3)))
cond_rm_facets <- function(
  facets = NULL,
  facets_regex = NULL,
  ancestor_pos = 1,
  split = NULL,
  split_regex = NULL,
  value = NULL,
  value_regex = NULL,
  keep_matches = FALSE
) {
  ## detect errors/miscalling which don't even require us to have the facets
  if (is.null(split) && is.null(split_regex) && is.null(value) && is.null(value_regex)) {
    stop(
      "Must specify condition in terms of at least one of ",
      "split name (split or split_regex) or ",
      "facet value (value or value_regex)."
    )
  }
  if (is.null(facets) && is.null(facets_regex)) {
    stop("Must specify facets either facets or facets_regex, got neither.")
  } else if (!is.null(facets) && !is.null(facets_regex)) {
    stop("Got both facets and facets_regex, this is not supported, please specify only one.")
  }
  function(ret, spl, .spl_context, fulldf) {
    torm_ind <- c()
    ancestor_pos <- resolve_ancestor_pos(ancestor_pos, NROW(.spl_context))
    torm_ind <- find_torm(ret, facets, facets_regex, keep_matches = keep_matches)
    fct_abbrev <- ifelse(is.null(facets_regex), paste(facets, collapse = ", "), facets_regex)
    if (length(torm_ind) == 0) {
      # nocov start
      warning(
        "No facets matched removal criteria [",
        fct_abbrev,
        "] ",
        "in function created with cond_rm_facets.\n",
        "Occured at path: ",
        spl_context_to_disp_path(.spl_context),
        call. = FALSE
      )
      # nocov end
    } else if (length(torm_ind) == length(ret$datasplit)) {
      # nocov start
      warning(
        "All facets matched removal criteria [",
        fct_abbrev,
        "] in function created with cond_rm_facets. ",
        "This will result in a degenerate table (if the condition ",
        "is met) within row splitting and in table-creation failing ",
        "entirely in column splitting.\n",
        "Occured at path: ",
        spl_context_to_disp_path(.spl_context),
        call. = FALSE
      )
      # nocov end
    }
    if (
      .check_rem_cond(split, split_regex, .spl_context, ancestor_pos, type = "split") &&
        .check_rem_cond(value, value_regex, .spl_context, ancestor_pos, type = "value")
    ) {
      ## find_torm handles the keep matching case, so by this point torm_ind is always the ones to remove
      ret <- lapply(ret, function(part) part[-torm_ind])
    }

    ret
  }
}


#' @name rm_levels
#'
#' @title Removal of Levels
#'
#' @description
#' custom function for removing level inside pre step in make_split_fun.
#'
#' @param excl Choose which level(s) to remove
#' @export
#'
rm_levels <- function(excl) {
  function(df, spl, ...) {
    var <- spl_variable(spl)
    varvec <- df[[var]]
    oldlevs <- levels(varvec)

    exclevs <- oldlevs %in% excl
    newlevs <- oldlevs[!exclevs]
    df[[var]] <- factor(df[[var]], levels = newlevs)
    df
  }
}

#' Shortcut for Creating Custom Column Splits
#'
#' This is a short cut for a common use of [rtables::make_split_result()] where you need to create
#' custom column splits with different labels but using the same full dataset for each column.
#' It automatically sets up the values, datasplit (using the same full dataset for each column),
#' and subset_exprs (using TRUE for all subsets) parameters for make_split_result().
#'
#' @param ... sequence of named labels for the columns.
#' @param fulldf (`data.frame`)\cr the `fulldf` which will be used for each column.
#' @return The result from [rtables::make_split_result()].
#'
#' @keywords internal
short_split_result <- function(..., fulldf) {
  labels <- c(...)
  values <- stats::setNames(names(labels), names(labels))
  datasplit <- stats::setNames(replicate(n = length(labels), list(fulldf)), names(labels))
  subset_exprs <- replicate(n = length(labels), list(expression(TRUE)))
  make_split_result(values = values, labels = labels, datasplit = datasplit, subset_exprs = subset_exprs)
}

#' Analysis Function for Response Variables
#'
#' This function calculates counts and percentages for response variables (Y/N values),
#' with optional risk difference calculations.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .var (`string`)\cr variable name that is passed by `rtables`.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param .N_col (`integer`)\cr column-wise N (column count) for the full column being analyzed.
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param resp_var (`string`)\cr response variable name containing Y/N values.
#' @param id (`string`)\cr subject variable name.
#' @param drop_levels (`logical`)\cr if TRUE, non-observed levels will not be included.
#' @param riskdiff (`logical`)\cr if TRUE, risk difference calculations will be performed.
#' @param ref_path (`string`)\cr column path specifications for the control group.
#' @param variables (`list`)\cr variables to include in the analysis.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param method (`character`)\cr method for calculating confidence intervals.
#' @param weights_method (`character`)\cr method for calculating weights.
#' @param ... Additional arguments passed to other functions.
#'
#' @return A list of rcell objects containing the response statistics.
#'
#' @export
#' @keywords internal
a_freq_resp_var_j <- function(
  df,
  .var,
  .df_row,
  .N_col,
  .spl_context,
  resp_var = NULL,
  id = "USUBJID",
  drop_levels = FALSE,
  riskdiff = TRUE,
  ref_path = NULL,
  variables = formals(s_proportion_diff)$variables,
  conf_level = formals(s_proportion_diff)$conf_level,
  method = c(
    "wald",
    "waldcc",
    "cmh",
    "ha",
    "newcombe",
    "newcombecc",
    "strat_newcombe",
    "strat_newcombecc"
  ),
  weights_method = formals(s_proportion_diff)$weights_method,
  ...
) {
  # ---- Derive statistics: xx / xx (xx.x%)

  if (is.null(resp_var)) {
    stop(
      "afun a_freq_resp_var_j: resp_var cannot be NULL."
    )
  }

  resp_var_values <- unique(df[[resp_var]][!is.na(df[[resp_var]])])
  if (
    is.character(df[[resp_var]]) &&
      any(is.na(df[[resp_var]])) &&
      all(resp_var_values == "Y")
  ) {
    stop(
      paste0(
        "afun a_freq_resp_var_j: it is not clear if missing resp_var should be considered non-response. ",
        "Please make it a factor with appropriate Y(/N) levels."
      )
    )
  }

  if (length(setdiff(resp_var_values, c("Y", "N"))) > 0) {
    stop("afun a_freq_resp_var_j: resp_var must contain only Y/N values.")
  }

  if (is.character(df[[resp_var]])) {
    df[[resp_var]] <- factor(df[[resp_var]], levels = c("Y", "N"))
  }

  df <- df[!is.na(df[[.var]]), ]

  if ((is.factor(df[[resp_var]]) &&
         (identical(levels(df[[resp_var]]), c("Y", "N")) || identical(levels(df[[resp_var]]), c("N", "Y")))) ||
      is.character(df[[resp_var]])
  ) {
    # missing values in resp_var should be excluded, not considered as not met response
    # subject will then not contribute to denominator
    df <- df[!is.na(df[[resp_var]]), ]
    .df_row <- .df_row[!is.na(.df_row[[resp_var]]), ]
  }

  if (drop_levels) {
    obs_levs <- unique(.df_row[[.var]])
    obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)

    val_var <- obs_levs
    # restrict the levels to the ones specified in val_var
    df <- df[df[[.var]] %in% val_var, ]
    .df_row <- .df_row[.df_row[[.var]] %in% val_var, ]

    df <- h_update_factor(df, .var, val_var)
  }

  varvec <- df[[.var]]

  levs <- if (is.factor(varvec)) levels(varvec) else sort(unique(varvec))

  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (riskdiff) {
    trt_var_refpath <- h_get_trtvar_refpath(
      ref_path,
      .spl_context,
      df
    )
    # trt_var_refpath is list with elements
    # trt_var trt_var_refspec cur_trt_grp ctrl_grp
    # make these elements available in current environment
    trt_var <- trt_var_refpath$trt_var
    trt_var_refspec <- trt_var_refpath$trt_var_refspec
    cur_trt_grp <- trt_var_refpath$cur_trt_grp
    ctrl_grp <- trt_var_refpath$ctrl_grp
  }

  fn <- function(levii) {
    dfii <- df[df[[.var]] == levii, ]
    dfrowii <- .df_row[.df_row[[.var]] == levii, ]

    if (!inriskdiffcol) {
      # use the core s_freq_j function on the current level of the incoming variable (.var)
      # note that the response variable will become .var in the below call
      # val is restricted to Y to show number of response on the current level of .var
      rslt <- s_freq_j(
        dfii,
        .df_row = dfrowii,
        .var = resp_var,
        alt_df = NULL,
        parent_df = NULL,
        val = "Y",
        denom = "n_df"
      )

      .stat <- "count_unique_denom_fraction"
      x_stat <- rslt[[.stat]]$Y
      rslt <- rcell(x_stat, format = jjcsformat_count_denom_fraction)
    } else {
      # use the risk differenc function s_rel_risk_val_j on the current level of the incoming variable (.var)
      # note that the response variable will become .var in the below call
      # val is restricted to Y to show number of response on the current level of .var
      denom_df <- dfrowii

      rslt <- s_rel_risk_val_j(
        df = dfii,
        .var = resp_var,
        .df_row = dfrowii,
        val = "Y",
        denom_df = denom_df,
        id = id,
        riskdiff = riskdiff,
        # treatment/ref group related arguments
        trt_var = trt_var,
        ctrl_grp = ctrl_grp,
        cur_trt_grp = cur_trt_grp,
        # relrisk specific arguments
        variables = variables,
        conf_level = conf_level,
        method = method,
        weights_method = weights_method
      )
      x_stat <- rslt[["rr_ci_3d"]]$Y
      rslt <- rcell(
        x_stat,
        format = jjcsformat_xx("xx.x (xx.x, xx.x)"),
        format_na_str = rep("NA", 3)
      )
    }

    # rslt is a single rcell row
    return(rslt)
  }

  ### apply function fn to all levels of incoming .var
  ### cls is a list of single rcell rows - ie one line per level is presented
  cls <- lapply(levs, fn)

  names(cls) <- levs
  return(cls)
}

#' Difference test for two proportions
#'
#' @description `r lifecycle::badge('stable')`
#'
#' The analysis function [a_test_proportion_diff()] can be used to create a layout element to test
#' the difference between two proportions. The primary analysis variable, `vars`, indicates whether a
#' response has occurred for each record. See the `method` parameter for options of methods to use
#' to calculate the p-value. Additionally, a stratification variable can be supplied via the `strata`
#' element of the `variables` argument. The argument `alternative` specifies the direction of the
#' alternative hypothesis.
#'
#' @inheritParams proposal_argument_convention
#' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`; specifies the test used
#'   to calculate the p-value.
#' @param .stats (`character`)\cr statistics to select for the table.
#'
#' @seealso [h_prop_diff_test]
#'
#' @note These functions have been forked from the `tern` package. Additional features are:
#'
#'   * Additional `alternative` argument for the sidedness of the test.
#'   * Additional `ref_path` argument for flexible reference column path specification.
#'
#' @name prop_diff_test
#' @order 1
NULL

#' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.
#'
#' @return
#' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`
#'   describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.
#'
#' @keywords internal
s_test_proportion_diff <- function(
  df,
  .var,
  .ref_group,
  .in_ref_col,
  variables = list(strata = NULL),
  method = c("chisq", "fisher", "cmh"),
  alternative = c("two.sided", "less", "greater")
) {
  method <- match.arg(method)
  alternative <- match.arg(alternative)
  y <- list(pval = list())

  if (!.in_ref_col) {
    assert_df_with_variables(df, list(rsp = .var))
    assert_df_with_variables(.ref_group, list(rsp = .var))
    rsp <- factor(c(.ref_group[[.var]], df[[.var]]), levels = c("TRUE", "FALSE"))
    grp <- factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))

    if (!is.null(variables$strata) || method == "cmh") {
      strata <- variables$strata
      checkmate::assert_false(is.null(strata))
      strata_vars <- stats::setNames(as.list(strata), strata)
      assert_df_with_variables(df, strata_vars)
      assert_df_with_variables(.ref_group, strata_vars)
      strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))
    }

    tbl <- switch(method, cmh = table(grp, rsp, strata), table(grp, rsp))

    y$pval <- switch(
      method,
      chisq = prop_chisq(tbl, alternative),
      cmh = prop_cmh(tbl, alternative),
      fisher = prop_fisher(tbl, alternative)
    )
  }

  y$pval <- with_label(y$pval, d_test_proportion_diff(method, alternative))
  y
}

#' Description of the difference test between two proportions
#'
#' @description `r lifecycle::badge('stable')`
#'
#' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.
#'
#' @inheritParams s_test_proportion_diff
#'
#' @return A `string` describing the test from which the p-value is derived.
#'
#' @export
d_test_proportion_diff <- function(method, alternative) {
  checkmate::assert_string(method)
  meth_part <- switch(
    method,
    chisq = "Chi-Squared Test",
    cmh = "Cochran-Mantel-Haenszel Test",
    fisher = "Fisher's Exact Test",
    stop(paste(method, "does not have a description"))
  )
  alt_part <- switch(
    alternative,
    two.sided = "",
    less = ", 1-sided, direction less",
    greater = ", 1-sided, direction greater"
  )
  paste0("p-value (", meth_part, alt_part, ")")
}

#' @describeIn prop_diff_test Formatted analysis function which is used as `afun`
#'
#' @return
#' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c('A', 'B'), each = 50)),
#'   strata = factor(rep(c('V', 'W', 'X', 'Y', 'Z'), each = 20))
#' )
#'
#' # With `rtables` pipelines.
#' l <- basic_table() |>
#'   split_cols_by(var = 'grp') |>
#'   analyze(
#'     vars = 'rsp',
#'     afun = a_test_proportion_diff,
#'     show_labels = 'hidden',
#'     extra_args = list(
#'       method = 'cmh',
#'       variables = list(strata = 'strata'),
#'       ref_path = c('grp', 'B')
#'     )
#'   )
#'
#' build_table(l, df = dta)
#'
#' @export
#' @order 2
a_test_proportion_diff <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_test_proportion_diff,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "test_proportion_diff",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Helper functions to test proportion differences
#'
#' Helper functions to implement various tests on the difference between two proportions.
#'
#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.
#'
#' @return A p-value.
#'
#' @seealso [prop_diff_test()] for implementation of these helper functions.
#'
#' @name h_prop_diff_test
NULL

#' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()].
#'
#' @keywords internal
prop_chisq <- function(tbl, alternative) {
  checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
  tbl <- tbl[, c("TRUE", "FALSE")]
  if (any(colSums(tbl) == 0)) {
    return(1)
  }
  stats::prop.test(tbl, correct = FALSE, alternative = alternative)$p.value
}

#' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test.
#'  Internally calls [stats::mantelhaen.test()].
#'
#' @note strata with less than five observations will result in a warning and
#'  possibly incorrect results; strata with less than two observations are
#'  automatically discarded.
#'
#' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response
#'   (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.
#'
#' @keywords internal
prop_cmh <- function(ary, alternative) {
  checkmate::assert_array(ary)
  checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)
  checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)
  strata_sizes <- apply(ary, MARGIN = 3, sum)
  if (any(strata_sizes < 5)) {
    warning("<5 data points in some strata. CMH test may be incorrect.")
    ary <- ary[, , strata_sizes > 1]
  }
  stats::mantelhaen.test(ary, correct = FALSE, alternative = alternative)$p.value
}

#' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()].
#'
#' @keywords internal
prop_fisher <- function(tbl, alternative) {
  checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
  tbl <- tbl[, c("TRUE", "FALSE")]
  stats::fisher.test(tbl, alternative = alternative)$p.value
}

.find_titles_file <- function(path = ".") {
  if (file.exists(file.path(path, "titles.csv"))) {
    file.path(path, "titles.csv")
  } else if (file.exists(file.path(path, "titles.xlsx"))) {
    file.path(path, "titles.xlsx")
  } else {
    stop("No titles.csv/xlsx file detected at path ", path,
         "please specify parent directory, full file path, or ",
         "pass the full titles data.frame directly.")
  }
}

#' @importFrom utils read.csv
.read_titles_file <- function(file) {
  if (grepl("csv$", file, ignore.case = TRUE)) {
    df <- read.csv(file)
  } else if (grepl("xlsx$", file, ignore.case = TRUE)) {
    if (!requireNamespace("readxl"))
      stop("readxl package is required for xslx file support, please install it.")
    df <- readxl::read_excel(df, sheet = 1, range = readxl::cell_cols("A:C"))
  } else {
    stop("Unrecognized titles file type. file: ", file)
  }
  df
}

# ----
#' @name  get_titles_from_file
#' @title Get Titles/Footers For Table From Sources
#'
#' @description Retrieves the titles and footnotes for a given table from a CSV/XLSX file or a data.frame.
#'
#' @details Retrieves the titles for a given output id (see below) and outputs
#'          a list containing the title and footnote objects supported by
#'          rtables. Both titles.csv and titles.xlsx (*if `readxl` is
#'          installed*) files are supported, with titles.csv being checked
#'          first.
#'
#'          Data is expected to have `TABLE ID`, `IDENTIFIER`, and `TEXT` columns,
#'          where `IDENTIFIER` has the value `TITLE` for a title and `FOOT*` for
#'          footer materials where `*` is a positive integer. `TEXT` contains
#'          the value of the title/footer to be applied.
#'
#' @param file (`character(1)`)\cr A path to CSV or xlsx file containing title
#'   and footer information for one or more outputs. See Details. Ignored if
#'   `title_df` is specified.
#' @param input_path (`character(1)`)\cr A path to look for
#'   titles.csv/titles.xlsx. Ignored if `file` or `title_df` is specified.
#' @param title_df (`data.frame`)\cr A data.frame containing titles and footers for
#'   one or more  outputs. See Details.
#' @param id character. The identifier for the table of interest.
#'
#' @export
#' @seealso Used in all template script
#' @examples # title_footer <- get_titles_from_file(tblid)
#'
#' @returns  List object containing: title, subtitles, main_footer, prov_footer
#'           for the table of interest.  Note: the subtitles and prov_footer are
#'           currently set to NULL. Suitable for use with [`set_titles()`].
#'
# ----

get_titles_from_file <- function(id,
                                 file = .find_titles_file(input_path),
                                 input_path = ".",
                                 title_df = .read_titles_file(file)) {
  title_df <- title_df[title_df[["TABLE ID"]] == id, , drop = FALSE]

  message(paste0("Static titles file/data.frame used: "))

  msg <- NULL

  if (nrow(title_df) == 0) {
    msg <- paste0(
      paste("Warning: Table ID", id, "not found in Title file."),
      "\n",
      "A dummy title will be generated to be able to get rtf file produced.",
      "\n",
      "Ensure the titles file gets updated to include the table identifier"
    )

    title <- "Table ID not found in titles file, dummy title for rtf generation purpose"
    main_footer <- "Ensure the titles file gets updated to include the table identifier"
  } else {
    title <- title_df[title_df$IDENTIFIER == "TITLE", ]$TEXT

    if (length(title) != 1) {
      msg <- "Warning: Title file should contain exactly one title record per Table ID"
    }

    main_footer <- title_df[grep("^FOOT", title_df$IDENTIFIER), ]$TEXT

    if (length(main_footer) == 0) {
      main_footer <- character()
    }
  }

  if (!is.null(msg)) {
    warning(msg)
  }

  # ---- Return titles and footnotes.

  title_foot <- list(title = title,
                     subtitles = NULL,
                     main_footer = main_footer,
                     prov_footer = NULL)

  return(title_foot)
}

# ----
#' @name  set_titles
#' @title Set Output Titles
#'
#' @description Retrieves titles and footnotes from the list specified in the titles
#'              argument and appends them to the table tree specified in the obj argument.
#'
#'
#' @param obj The table tree to which the titles and footnotes will be appended.
#' @param titles The list object containing the titles and footnotes to be appended.
#' @seealso Used in all template scripts
#' @export
#' @examples # set_titles(obj, get_titles_csv(tblid))
#'
#' @returns  The table tree object specified in the obj argument, with titles
#'           and footnotes appended.
#'
# ----

set_titles <- function(obj, titles) {
  ## add title and footers
  main_title(obj) <- titles$title
  if (!is.null(titles$subtitles)) {
    subtitles(obj) <- titles$subtitles
  }
  main_footer(obj) <- titles$main_footer
  if (!is.null(titles$prov_footer)) {
    prov_footer(obj) <- titles$prov_footer
  }

  return(obj)
}

.onLoad <- function(libname, pkgname) {
  settings <- list(
    # A named list for tracking table names and counts in `insert_blank_line()`
    junco.insert_blank_line = list()
  )

  to_set <- !names(settings) %in% names(options())
  if (any(to_set)) options(settings[to_set])
  invisible()
}


.onUnload <- function(libpath) {
  settings <- list(
    junco.insert_blank_line = NULL
  )

  options(settings)
  invisible()
}

#' @title s_function for proportion of factor levels
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format. The denominator here is from the alternative counts data set
#'   in the given row and column split.
#'
#'   If a total row is shown, then here just the total number is shown (without 100%).
#' @param x (`factor`)\cr categorical variable we want to analyze.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param use_alt_counts (`flag`)\cr whether the `.alt_df` should be used for the total, i.e. the denominator.
#'   If not, then the number of non-missing values in `x` is used.
#' @param show_total (`string`)\cr show the total level optionally on the top or in the bottom
#'   of the factor levels.
#' @param total_label (`string`)\cr which label to use for the optional total level.
#' @return The [rtables::in_rows()] result with the proportion statistics.
#' @seealso [s_proportion_logical()] for tabulating logical `x`.
#' @export
s_proportion_factor <- function(
  x,
  .alt_df,
  use_alt_counts = TRUE,
  show_total = c("none", "top", "bottom"),
  total_label = "Total"
) {
  checkmate::assert_factor(x)
  checkmate::assert_flag(use_alt_counts)
  show_total <- match.arg(show_total)

  N <- if (use_alt_counts) nrow(.alt_df) else sum(!is.na(x))
  tab <- lapply(as.list(table(x)), function(xi) rcell(xi * c(1, 1 / N), format = jjcsformat_count_fraction))
  if (show_total != "none") {
    checkmate::assert_string(total_label)
    tab_total <- stats::setNames(list(rcell(N, format = "xx")), total_label)

    tab <- if (show_total == "top") {
      c(tab_total, tab)
    } else {
      c(tab, tab_total)
    }
  }
  in_rows(.list = tab)
}

#' @title s_function for proportion of `TRUE` in logical vector
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format. The denominator here is from the alternative counts data set
#'   in the given row and column split.
#' @param x (`logical`)\cr binary variable we want to analyze.
#' @param label (`string`)\cr label to use.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @return The [rtables::in_rows()] result with the proportion statistics.
#' @seealso [s_proportion_factor()] for tabulating factor `x`.
#' @export
s_proportion_logical <- function(x, label = "Responders", .alt_df) {
  n <- sum(x)
  N <- nrow(.alt_df)
  p_hat <- n / N
  list(n_prop = with_label(rcell(c(n, p_hat), format = jjcsformat_count_fraction), label))
}

#' @title c_function for proportion of `TRUE` in logical vector
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format, for use in a split content row. The denominator here is
#'   from the column N. Note that we don't use here .alt_df because that might not
#'   have required row split variables available.
#' @param x (`logical`)\cr binary variable we want to analyze.
#' @param labelstr (`string`)\cr label string.
#' @param labelstr (`string`)\cr label string.
#' @param label_fstr (`string`)\cr format string for the label.
#' @param format (`character` or `list`)\cr format for the statistics.
#' @param .N_col (`numeric`)\cr number of columns.
#' @param .N_col (`numeric`)\cr number of columns.
#' @return The [rtables::in_rows()] result with the proportion statistics.
#' @seealso [s_proportion_logical()] for the related statistics function.
#' @export
c_proportion_logical <- function(x, labelstr, label_fstr, format, .N_col) {
  checkmate::assert_logical(x)
  num <- sum(x)
  denom <- .N_col
  in_rows(est_prop = c(num, num / denom), .formats = format, .labels = sprintf(label_fstr, labelstr))
}

#' Helper Function to Create Logical Design Matrix from Factor Variable
#'
#' @param df (`data.frame`)\cr including a factor variable with name in `.var`.
#' @param .var (`string`)\cr name of the factor variable.
#'
#' @return The logical matrix with dummy encoding of all factor levels.
#' @keywords internal
#' @export
#' @examples
#' h_get_design_mat(df = data.frame(a = factor(c('a', 'b', 'a'))), .var = 'a')
h_get_design_mat <- function(df, .var) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_factor(df[[.var]])

  model_formula <- stats::as.formula(paste("~ -1 +", .var))
  design_mat <- stats::model.matrix(model_formula, df)
  mode(design_mat) <- "logical"
  colnames(design_mat) <- levels(df[[.var]])
  design_mat
}

#' Formatted Analysis Function For Proportion Confidence Interval for Logical
#'
#' @param x (`logical`)\cr including binary response values.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param formats (`list`)\cr including element `prop_ci` with the
#'   required format. Note that the value is in percent already.
#' @param method (`string`)\cr please see [tern::s_proportion()] for possible
#'   methods.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#'
#' @return The [rtables::rcell()] result.
#' @export
#'
#' @examples
#' a_proportion_ci_logical(
#'   x = DM$SEX == 'F',
#'   .alt_df = DM,
#'   conf_level = 0.95,
#'   formats = list(prop_ci = jjcsformat_xx('xx.xx% - xx.xx%')),
#'   method = 'wald'
#' )
a_proportion_ci_logical <- function(x, .alt_df, conf_level, method, formats) {
  checkmate::assert_logical(x)
  checkmate::assert_data_frame(.alt_df)
  checkmate::assert_list(formats)

  diff_n <- nrow(.alt_df) - length(x)
  if (diff_n > 0) {
    x <- c(x, rep(FALSE, length = diff_n))
  }
  est <- s_proportion(x, conf_level = conf_level, method = method)
  rcell(est$prop_ci, format = formats$prop_ci)
}

#' Formatted Analysis Function For Proportion Confidence Interval for Factor
#'
#' @param df (`data.frame`)\cr including factor `.var`.
#' @param .var (`string`)\cr name of the factor variable.
#' @param .var (`string`)\cr name of the factor variable.
#' @param \dots see [a_proportion_ci_logical()] for additionally required
#'   arguments.
#'
#' @return The [rtables::rcell()] result.
#' @export
#'
#' @examples
#' a_proportion_ci_factor(
#'   df = DM,
#'   .var = 'SEX',
#'   .alt_df = DM,
#'   conf_level = 0.95,
#'   formats = list(prop_ci = jjcsformat_xx('xx.x%, xx.x%')),
#'   method = 'clopper-pearson'
#' )
a_proportion_ci_factor <- function(df, .var, ...) {
  checkmate::assert_factor(df[[.var]])

  design_mat <- h_get_design_mat(df, .var)
  design_df <- as.data.frame(design_mat)
  res <- lapply(design_df, a_proportion_ci_logical, ...)
  in_rows(.list = res, .labels = colnames(design_mat))
}

#' Split Function for Proportion Analysis Columns (TEFCGIS08 e.g.)
#'
#' Here we just split into 3 columns `n`, `%` and `Cum %`.
#'
#' @param ret (`list`)\cr return value from the previous split function.
#' @param spl (`list`)\cr split information.
#' @param fulldf (`data.frame`)\cr full data frame.
#' @param .spl_context (`environment`)\cr split context environment.
#'
#' @note This split function is used in the proportion table TEFCGIS08 and similar ones.
#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
#'   post-processing function.
prop_post_fun <- function(ret, spl, fulldf, .spl_context) {
  short_split_result(n = "n", percent = "%", cum_percent = "Cum %", fulldf = fulldf)
}

#' @rdname prop_post_fun
#'
#' @param df A data frame that contains all analysis variables.
#' @param vals A character vector that contains values to use for the split.
#' @param labels A character vector that contains labels for the statistics (without indent).
#' @param trim A single logical that indicates whether to trim the values.
#'
#' @export
prop_split_fun <- make_split_fun(post = list(prop_post_fun))

#' Formatted Analysis Function for Proportion Analysis (TEFCGIS08 e.g.)
#'
#' This function applies to a factor `x` when a column split was prepared with
#' [prop_split_fun()] before.
#'
#' @details In the column named `n`, the counts of the categories as well as an
#' optional `Total` count will be shown. In the column named `percent`, the
#' percentages of the categories will be shown, with an optional blank entry for
#' `Total`. In the column named `cum_percent`, the cumulative percentages will
#' be shown instead.
#'
#' @param x (`factor`)\cr factor variable to analyze.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param formats (`list`)\cr formats for the statistics.
#' @param add_total_level (`flag`)\cr whether to add a total level.
#' @param x (`factor`)\cr factor variable to analyze.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param formats (`list`)\cr formats for the statistics.
#' @param add_total_level (`flag`)\cr whether to add a total level.
#'
#' @return The formatted result as [rtables::rcell()].
#' @export
prop_table_afun <- function(x, .spl_context, formats, add_total_level = FALSE) {
  checkmate::assert_list(formats, len = 3, names = "unique")
  checkmate::assert_names(names(formats), permutation.of = c("n", "percent", "cum_percent"))
  checkmate::assert_flag(add_total_level)

  stat <- utils::tail(.spl_context[nrow(.spl_context), "cur_col_split_val"][[1]], 1)
  optional_total <- function(x) if (add_total_level) x else NULL
  ns <- table(x)
  res <- if (stat == "n") {
    c(as.list(ns), optional_total(length(x)))
  } else if (stat == "percent") {
    c(as.list(ns / length(x) * 100), optional_total(list(NULL)))
  } else if (stat == "cum_percent") {
    c(as.list(cumsum(ns / length(x) * 100)), optional_total(list(NULL)))
  } else {
    stop("unexpected proportion statistic in split")
  }
  in_rows(.list = res, .labels = c(levels(x), optional_total("Total")), .formats = formats[[stat]])
}

#' Proportion difference estimation
#'
#' The analysis function [a_proportion_diff_j()] can be used to create a layout element to estimate
#' the difference in proportion of responders within a studied population. The primary analysis variable,
#' `vars`, is a logical variable indicating whether a response has occurred for each record. See the `method`
#' parameter for options of methods to use when constructing the confidence interval of the proportion difference.
#' A stratification variable can be supplied via the `strata` element of the `variables` argument.
#'
#' @param df (`data.frame`)\cr input data frame.
#' @param .var (`string`)\cr name of the response variable.
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#' @param .ref_group (`data.frame`)\cr reference group data frame.
#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
#' @param variables (`list`)\cr list with strata variable names.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param method (`string`)\cr method to use for confidence interval calculation.
#' @param weights_method (`string`)\cr method to use for weights calculation in stratified analysis.
#'
#' @name prop_diff
#' @order 1
#'
#' @note The [a_proportion_diff_j()] function has the `_j` suffix to distinguish it
#'   from [tern::a_proportion_diff()]. The functions here are a copy from the `tern` package
#'   with additional features:
#'
#'   * Additional statistic `diff_est_ci` is returned.
#'   * `ref_path` needs to be provided as extra argument to specify the control group column.
#'
NULL

#' @describeIn prop_diff Statistics function estimating the difference
#'   in terms of responder proportion.
#'
#' @return
#' * `s_proportion_diff_j()` returns a named list of elements `diff`,
#'    `diff_ci`, `diff_est_ci` and `diff_ci_3d`.
#'
#' @note When performing an unstratified analysis, methods `'cmh'`, `'strat_newcombe'`,
#'   and `'strat_newcombecc'` are not permitted.
#'
#' @examples
#'
#' s_proportion_diff_j(
#'   df = subset(dta, grp == 'A'),
#'   .var = 'rsp',
#'   .ref_group = subset(dta, grp == 'B'),
#'   .in_ref_col = FALSE,
#'   conf_level = 0.90,
#'   method = 'ha'
#' )
#'
#' # CMH example with strata
#' s_proportion_diff_j(
#'   df = subset(dta, grp == 'A'),
#'   .var = 'rsp',
#'   .ref_group = subset(dta, grp == 'B'),
#'   .in_ref_col = FALSE,
#'   variables = list(strata = c('f1', 'f2')),
#'   conf_level = 0.90,
#'   method = 'cmh'
#' )
#'
#' @export
#' @order 3
s_proportion_diff_j <- function(
  df,
  .var,
  .ref_group,
  .in_ref_col,
  variables = list(strata = NULL),
  conf_level = 0.95,
  method = c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc"),
  weights_method = "cmh"
) {
  start <- s_proportion_diff(
    df = df,
    .var = .var,
    .ref_group = .ref_group,
    .in_ref_col = .in_ref_col,
    variables = variables,
    conf_level = conf_level,
    method = method,
    weights_method = weights_method
  )

  c(
    start,
    list(
      diff_est_ci = with_label(
        c(start$diff, start$diff_ci),
        paste0("% Difference (", f_conf_level(conf_level), ")")
      ),
      diff_ci_3d = with_label(
        c(start$diff, start$diff_ci),
        paste0("Relative Risk (", f_conf_level(conf_level), ")")
      )
    )
  )
}

#' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.
#'
#' @return
#' * `a_proportion_diff_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' ## 'Mid' case: 4/4 respond in group A, 1/2 respond in group B.
#' nex <- 100 # Number of example rows
#' dta <- data.frame(
#'   'rsp' = sample(c(TRUE, FALSE), nex, TRUE),
#'   'grp' = sample(c('A', 'B'), nex, TRUE),
#'   'f1' = sample(c('a1', 'a2'), nex, TRUE),
#'   'f2' = sample(c('x', 'y', 'z'), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' l <- basic_table() |>
#'   split_cols_by(var = 'grp') |>
#'   analyze(
#'     vars = 'rsp',
#'     afun = a_proportion_diff_j,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     extra_args = list(
#'       conf_level = 0.9,
#'       method = 'ha',
#'       ref_path = c('grp', 'B')
#'     )
#'   )
#'
#' build_table(l, df = dta)
#' @export
#' @order 2
a_proportion_diff_j <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_proportion_diff_j,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "proportion_diff",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' @name create_colspan_var
#' @title Creation of Column Spanning Variables
#' @description
#' A function used for creating a spanning variable for treatment groups
#' @details
#' This function creates a spanning variable for treatment groups that is intended to
#' be used within the column space.
#' @param df The name of the data frame in which the spanning variable is to be appended to
#' @param non_active_grp The value(s) of the treatments that represent the non-active or comparator
#' treatment groups
#' default value = c('Placebo')
#' @param non_active_grp_span_lbl The assigned value of the spanning variable for the non-active or comparator
#' treatment groups
#' default value = ''
#' @param active_grp_span_lbl The assigned value of the spanning variable for the active treatment group(s)
#' default value = 'Active Study Agent'
#' @param colspan_var The desired name of the newly created spanning variable
#' default value = 'colspan_trt'
#' @param trt_var The name of the treatment variable that is used to determine which
#' spanning treatment group value to apply.
#' default value = 'TRT01A'
#' @returns a data frame that contains the new variable as specified in colspan_var
#' @rdname colspan_var
#' @export
#' @aliases create_colspan_var
#' @examples
#'
#' library(tibble)
#'
#' df <- tribble(
#'   ~TRT01A,
#'   'Placebo',
#'   'Active 1',
#'   'Active 2'
#' )
#'
#' df$TRT01A <- factor(df$TRT01A, levels = c('Placebo', 'Active 1', 'Active 2'))
#'
#' colspan_var <- create_colspan_var(
#'   df = df,
#'   non_active_grp = c('Placebo'),
#'   non_active_grp_span_lbl = ' ',
#'   active_grp_span_lbl = 'Active Treatment',
#'   colspan_var = 'colspan_trt',
#'   trt_var = 'TRT01A'
#' )
#'
#' colspan_var
create_colspan_var <- function(
  df,
  non_active_grp = c("Placebo"),
  non_active_grp_span_lbl = " ",
  active_grp_span_lbl = "Active Study Agent",
  colspan_var = "colspan_trt",
  trt_var = "TRT01A"
) {
  # Create a new column with the specified name using base R
  df[[colspan_var]] <- factor(
    ifelse(df[[trt_var]] %in% non_active_grp, non_active_grp_span_lbl, active_grp_span_lbl),
    levels = c(active_grp_span_lbl, non_active_grp_span_lbl)
  )

  return(df)
}

#' @name create_colspan_map
#' @title Creation of Column Spanning Mapping Dataframe
#' @description
#' A function used for creating a data frame containing the map that is compatible with rtables split function
#' `trim_levels_to_map`
#' @details
#' This function creates a data frame containing the map that is compatible with rtables split function
#' `trim_levels_to_map`.
#' The levels of the specified trt_var variable will be stored within the trt_var variable
#' and the colspan_var variable will contain the corresponding spanning header value for each treatment group.
#' @inheritParams create_colspan_var
#' @param active_first whether the active columns come first.
#' @returns a data frame that contains the map to be used with rtables split function `trim_levels_to_map`
#' @rdname colspan_map
#' @export
#' @examples
#' library(tibble)
#'
#' df <- tribble(
#'   ~TRT01A,
#'   'Placebo',
#'   'Active 1',
#'   'Active 2'
#' )
#'
#' df$TRT01A <- factor(df$TRT01A, levels = c('Placebo', 'Active 1', 'Active 2'))
#'
#' colspan_map <- create_colspan_map(
#'   df = df,
#'   non_active_grp = c('Placebo'),
#'   non_active_grp_span_lbl = ' ',
#'   active_grp_span_lbl = 'Active Study Agent',
#'   colspan_var = 'colspan_trt',
#'   trt_var = 'TRT01A'
#' )
#'
#' colspan_map
create_colspan_map <- function(
  df,
  non_active_grp = c("Placebo"),
  non_active_grp_span_lbl = " ",
  active_grp_span_lbl = "Active Study Agent",
  colspan_var = "colspan_trt",
  trt_var = "TRT01A",
  active_first = TRUE
) {
  act_trtlv <- setdiff(levels(df[[trt_var]]), non_active_grp)
  act_map_df <- data.frame(a = active_grp_span_lbl, b = act_trtlv)
  nact_map_df <- data.frame(a = non_active_grp_span_lbl, b = non_active_grp)
  df <- if (active_first) {
    rbind(act_map_df, nact_map_df)
  } else {
    rbind(nact_map_df, act_map_df)
  }
  names(df) <- c(colspan_var, trt_var)

  return(df)
}

#' Get Visit Levels in Order Defined by Numeric Version
#'
#' @param visit_cat (`character`)\cr the categorical version.
#' @param visit_n (`numeric`)\cr the numeric version.
#'
#' @return The unique visit levels in the order defined by the numeric version.
#' @export
#'
#' @examples
#' get_visit_levels(
#'   visit_cat = c('Week 1', 'Week 11', 'Week 2'),
#'   visit_n = c(1, 5, 2)
#' )
get_visit_levels <- function(visit_cat, visit_n) {
  checkmate::assert_character(visit_cat)
  checkmate::assert_numeric(visit_n)

  nvar <- "n"
  visit_levels_df <- unique(data.frame(cat = visit_cat, n = visit_n))
  visit_levels_df <- visit_levels_df[order(visit_levels_df$n), ]
  visit_levels <- visit_levels_df$cat

  checkmate::assert_character(visit_levels, unique = TRUE)

  visit_levels
}


add_blank_line_rcells <- function(ret) {
  # check that ret is expected structure and not NULL
  if (is.null(ret)) {
    stop("add_blank_line_rcells: ret cannot be NULL.")
  }
  if (!(class(ret) %in% c("RowsVerticalSection", "CellValue"))) {
    stop("add_blank_line_rcells:  ret must be of class RowsVerticalSection or CellValue.")
  }

  if (inherits(ret, "RowsVerticalSection")) {
    xlabel <- attr(ret, "row_labels")
    indent_mods <- lapply(ret, function(obj) {
      attr(obj, "indent_mod")
    })
  } else {
    xlabel <- attr(ret, "label")
    indent_mods <- attr(ret, "indent_mod")
  }

  fmts <- lapply(ret, obj_format)
  na_strs <- lapply(ret, obj_na_str)
  # ret <- append(ret,rcell(NA_real_,format = 'xx')) use a character version for the new line, rather than NA - to
  # allow NA processing for other stuff
  ret <- append(ret, rcell(NA, format = "xx"))
  fmts <- append(fmts, "xx")
  na_strs <- append(na_strs, " ")
  indent_mods <- append(indent_mods, 0L)
  xlabel <- append(xlabel, " ")
  ret <- stats::setNames(ret, xlabel)

  # perform the update to add the extra line
  fret <- in_rows(
    .list = ret,
    .labels = xlabel,
    .formats = fmts,
    .format_na_strs = na_strs,
    .indent_mods = indent_mods
  )

  fret
}

#' Analysis of Covariance
#'
#' Performs an analysis of covariance between two groups returning the estimated
#' "treatment effect" (i.e. the contrast between the two treatment groups) and
#' the least square means estimates in each group.
#'
#' @param data A `data.frame` containing the data to be used in the model.
#' @param vars A `vars` object as generated by [set_vars()]. Only the `group`,
#' `visit`, `outcome` and `covariates` elements are required. See details.
#' @param visits An optional character vector specifying which visits to
#' fit the ancova model at. If `NULL`, a separate ancova model will be fit to the
#' outcomes for each visit (as determined by `unique(data[[vars$visit]])`).
#' See details.
#' @param weights Character, either `"counterfactual"` (default), `"equal"`,
#' `"proportional_em"` or `"proportional"`.
#' Specifies the weighting strategy to be used when calculating the lsmeans.
#' See the weighting section for more details.
#'
#' @details
#' The function works as follows:
#'
#' 1. Select the first value from `visits`.
#' 2. Subset the data to only the observations that occurred on this visit.
#' 3. Fit a linear model as  `vars$outcome ~ vars$group + vars$covariates`.
#' 4. Extract the "treatment effect" & least square means for each treatment group.
#' 5. Repeat points 2-3 for all other values in `visits`.
#'
#' If no value for `visits` is provided then it will be set to
#' `unique(data[[vars$visit]])`.
#'
#' In order to meet the formatting standards set by [rbmi_analyse()] the results will be collapsed
#' into a single list suffixed by the visit name, e.g.:
#' ```
#' list(
#'    var_visit_1 = list(est = ...),
#'    trt_B_visit_1 = list(est = ...),
#'    lsm_A_visit_1 = list(est = ...),
#'    lsm_B_visit_1 = list(est = ...),
#'    var_visit_2 = list(est = ...),
#'    trt_B_visit_2 = list(est = ...),
#'    lsm_A_visit_2 = list(est = ...),
#'    lsm_B_visit_2 = list(est = ...),
#'    ...
#' )
#' ```
#' Please note that "trt" refers to the treatment effects, and "lsm" refers to the least
#' square mean results. In the above example `vars$group` has two factor levels A and B.
#' The new "var" refers to the model estimated variance of the residuals.
#'
#' If you want to include interaction terms in your model this can be done
#' by providing them to the `covariates` argument of [set_vars()]
#' e.g. `set_vars(covariates = c("sex*age"))`.
#'
#' @note These functions have the `rbmi_` prefix to distinguish them from the corresponding
#'   `rbmi` package functions, from which they were copied from. Additional features here
#'   include:
#'
#'   * Support for more than two treatment groups.
#'   * Variance estimates are returned.
#'
#' @seealso [rbmi_analyse()]
#' @seealso [stats::lm()]
#' @seealso [set_vars()]
#' @export
rbmi_ancova <- function(
  data,
  vars,
  visits = NULL,
  weights = c("counterfactual", "equal", "proportional_em", "proportional")
) {
  outcome <- vars[["outcome"]]
  group <- vars[["group"]]
  covariates <- vars[["covariates"]]
  visit <- vars[["visit"]]
  weights <- match.arg(weights)

  expected_vars <- c(
    utils::getFromNamespace("extract_covariates", "rbmi")(covariates),
    outcome,
    group
  )

  if (is.null(visits)) {
    visits <- unique(data[[visit]])
  }

  res <- lapply(
    visits,
    function(x) {
      data2 <- data[data[[visit]] == x, ]
      res <- rbmi_ancova_single(data2, outcome, group, covariates, weights)
      names(res) <- paste0(names(res), "_", x)
      return(res)
    }
  )
  return(unlist(res, recursive = FALSE))
}


#' Implements an Analysis of Covariance (ANCOVA)
#'
#' @description
#' Performance analysis of covariance. See [rbmi_ancova()] for full details.
#'
#' @param outcome string, the name of the outcome variable in `data`.
#' @param group string, the name of the group variable in `data`.
#' @param covariates character vector containing the name of any additional covariates
#' to be included in the model as well as any interaction terms.
#'
#' @inheritParams rbmi_ancova
#'
#' @details
#' - `group` must be a factor variable with only 2 levels.
#' - `outcome` must be a continuous numeric variable.
#' @export
#' @examples
#'
#' iris2 <- iris[iris$Species %in% c("versicolor", "virginica"), ]
#' iris2$Species <- factor(iris2$Species)
#' rbmi_ancova_single(iris2, "Sepal.Length", "Species", c("Petal.Length * Petal.Width"))
#'
#' @seealso [rbmi_ancova()]
rbmi_ancova_single <- function(
  data,
  outcome,
  group,
  covariates,
  weights = c("counterfactual", "equal", "proportional_em", "proportional")
) {
  checkmate::assert_string(outcome)
  checkmate::assert_string(group)
  weights <- match.arg(weights)

  checkmate::assert_factor(data[[group]], n.levels = 2L)
  checkmate::assert_numeric(data[[outcome]])
  data2 <- data[, c(
    utils::getFromNamespace("extract_covariates", "rbmi")(covariates),
    outcome,
    group
  )]

  frm <- utils::getFromNamespace("as_simple_formula", "rbmi")(
    outcome,
    c(group, covariates)
  )

  mod <- stats::lm(formula = frm, data = data2)

  args <- list(model = mod, .weights = weights)

  grp_levels <- levels(data2[[group]])

  all_lsm <- lapply(
    grp_levels,
    \(x) {
      do.call(
        utils::getFromNamespace("lsmeans", "rbmi"),
        c(args, stats::setNames(x, group))
      )
    }
  )
  names(all_lsm) <- paste0("lsm_", grp_levels)

  var_est <- summary(mod)$sigma^2
  var_df <- stats::df.residual(mod)

  all_trt <- lapply(
    paste0(group, grp_levels[-1]),
    \(x) {
      list(
        est = stats::coef(mod)[x],
        se = sqrt(stats::vcov(mod)[x, x]),
        df = var_df
      )
    }
  )
  names(all_trt) <- paste0("trt_", grp_levels[-1])

  var_res <- list(
    var = list(
      est = var_est,
      # Reference: Davison, Statistical Methods, p. 371 (just above 8.3.2)
      se = var_est / sqrt(var_df / 2),
      df = var_df
    )
  )

  c(var_res, all_trt, all_lsm)
}

#' Get default statistical methods and their associated formats, labels, and indent modifiers
#'
#' @description `r lifecycle::badge('experimental')`
#'
#' Utility functions to get valid statistic methods for different method groups
#' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers
#' (`.indent_mods`). This utility is used across `junco`, but some of its working principles can be
#' seen in [analyze_vars()]. See notes to understand why this is experimental.
#'
#' @param stats (`character`)\cr statistical methods to return defaults for.
#' @param levels_per_stats (named `list` of `character` or `NULL`)\cr named list where the name of each element is a
#'   statistic from `stats` and each element is the levels of a `factor` or `character` variable (or variable name),
#'   each corresponding to a single row, for which the named statistic should be calculated for. If a statistic is only
#'   calculated once (one row), the element can be either `NULL` or the name of the statistic. Each list element will be
#'   flattened such that the names of the list elements returned by the function have the format `statistic.level` (or
#'   just `statistic` for statistics calculated for a single row). Defaults to `NULL`.
#'
#' @details
#' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `junco_get_stats()`.
#'
#' @note
#' These defaults are experimental because we use the names of functions to retrieve the default
#' statistics. This should be generalized in groups of methods according to more reasonable groupings.
#'
#' These functions have been modified from the `tern` file `utils_default_stats_formats_labels.R`.
#' This file contains `junco` specific wrappers of functions called within the `afun` functions,
#' in order to point to `junco` specific default statistics, formats and labels.
#'
#' @name default_stats_formats_labels
NULL

#' @describeIn default_stats_formats_labels Get statistics available for a given method
#'   group (analyze function). To check available defaults see `junco_default_stats` list.
#'
#' @param method_groups (`character`)\cr indicates the statistical method group (`junco` analyze function)
#'   to retrieve default statistics for. A character vector can be used to specify more than one statistical
#'   method group.
#' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. If custom statistical
#'   functions are used, `stats_in` needs to have them in too.
#' @param custom_stats_in (`character`)\cr custom statistics to add to the default statistics.
#' @param add_pval (`flag`)\cr should `'pval'` (or `'pval_counts'` if `method_groups` contains
#'   `'analyze_vars_counts'`) be added to the statistical methods?
#'
#' @return
#' * `junco_get_stats()` returns a `character` vector of statistical methods.
#'
#' @export
junco_get_stats <- function(
  method_groups = "analyze_vars_numeric",
  stats_in = NULL,
  custom_stats_in = NULL,
  add_pval = FALSE
) {
  tern_get_stats(
    method_groups = method_groups,
    stats_in = stats_in,
    custom_stats_in = custom_stats_in,
    add_pval = add_pval,
    tern_defaults = junco_default_stats
  )
}

#' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics.
#'   To check available defaults see list `junco_default_formats`.
#'
#' @param formats_in (named `vector`)\cr custom formats to use instead of defaults. Can be a character vector with
#'   values from [formatters::list_valid_format_labels()] or custom format functions. Defaults to `NULL` for any rows
#'   with no value is provided.
#'
#' @return
#' * `junco_get_formats_from_stats()` returns a named list of formats as strings or functions.
#'
#' @note Formats in `tern` or `junco` and `rtables` can be functions that take in the table cell value and
#'   return a string. This is well documented in `vignette('custom_appearance', package = 'rtables')`.
#'
#' @export
junco_get_formats_from_stats <- function(stats, formats_in = NULL, levels_per_stats = NULL) {
  tern_get_formats_from_stats(
    stats = stats,
    formats_in = formats_in,
    levels_per_stats = levels_per_stats,
    tern_defaults = junco_default_formats
  )
}

#' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics.
#'   To check for available defaults see list `junco_default_labels`.
#'
#' @param labels_in (named `character`)\cr custom labels to use instead of defaults. If no value is provided, the
#'   variable level (if rows correspond to levels of a variable) or statistic name will be used as label.
#' @param label_attr_from_stats (named `list`)\cr if `labels_in = NULL`, then this will be used instead. It is a list
#'   of values defined in statistical functions as default labels. Values are ignored if `labels_in` is provided or `''`
#'   values are provided.
#'
#' @return
#' * `junco_get_labels_from_stats()` returns a named list of labels as strings.
#'
#' @export
junco_get_labels_from_stats <- function(
  stats,
  labels_in = NULL,
  levels_per_stats = NULL,
  label_attr_from_stats = NULL
) {
  tern_get_labels_from_stats(
    stats = stats,
    labels_in = labels_in,
    levels_per_stats = levels_per_stats,
    label_attr_from_stats = label_attr_from_stats,
    tern_defaults = junco_default_labels
  )
}

#' @describeIn default_stats_formats_labels Get label attributes from statistics list.
#' @param x_stats (`list`)\cr with the statistics results.
#' @keywords internal
get_label_attr_from_stats <- function(x_stats) {
  sapply(x_stats, obj_label)
}

#' @describeIn default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.
#'
#' @param indents_in (named `integer`)\cr custom row indent modifiers to use instead of defaults. Defaults to `0L` for
#'   all values.
#'
#' @return
#' * `junco_get_indents_from_stats()` returns a named list of indentation modifiers as integers. By default all of the
#'   indentations will be zero.
#'
#' @export
junco_get_indents_from_stats <- function(stats, indents_in = NULL, levels_per_stats = NULL) {
  # For statistics still remaining without default indentation after looking in junco_default_indents, use
  # indentation 0 as default.
  remaining_stats <- setdiff(stats, names(junco_default_indents))
  default_indents <- c(
    junco_default_indents,
    as.list(rep(0L, length(remaining_stats))) |>
      stats::setNames(remaining_stats)
  )

  tern_get_indents_from_stats(
    stats = stats,
    indents_in = indents_in,
    levels_per_stats = levels_per_stats,
    tern_defaults = default_indents
  )
}

#' @describeIn default_stats_formats_labels Format statistics results according to format specifications.
#'
#' @return
#' * `format_stats()` returns the correspondingly formatted [rtables::in_rows()] result.
#'
#' @export
format_stats <- function(x_stats, method_groups, stats_in, formats_in, labels_in, indents_in) {
  .stats <- junco_get_stats(method_groups, stats_in = stats_in)

  .formats <- junco_get_formats_from_stats(stats = .stats, formats_in = formats_in)

  label_attr <- get_label_attr_from_stats(x_stats)
  .labels <- junco_get_labels_from_stats(stats = .stats, labels_in = labels_in, label_attr_from_stats = label_attr)
  .labels <- .unlist_keep_nulls(.labels)

  .indent_mods <- junco_get_indents_from_stats(stats = .stats, indents_in = indents_in)
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  x_stats <- x_stats[.stats]

  in_rows(
    .list = x_stats,
    .formats = .formats,
    .names = names(.labels),
    .labels = .labels,
    .indent_mods = .indent_mods
  )
}


# junco_default_stats -----------------------------------------------------------

#' @describeIn default_stats_formats_labels Named list of available statistics by method group for `junco`.
#'
#' @format
#' * `junco_default_stats` is a named list of available statistics, with each element
#'   named for their corresponding statistical method group.
#'
#' @export
junco_default_stats <- list(
  coxph_hr = c("n_tot", "n_tot_events", "hr", "hr_ci", "hr_ci_3d", "pvalue", "lr_stat_df"),
  event_free = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "event_free_ci"),
  kaplan_meier = c("quantiles_lower", "median_ci_3d", "quantiles_upper", "range_with_cens_info"),
  odds_ratio = c("n_tot", "or_ci", "pval"),
  proportion_diff = c("diff", "diff_ci", "diff_est_ci"),
  relative_risk = c("rel_risk_ci", "pval"),
  summarize_ancova_j = c(
    "n",
    "mean_sd",
    "median",
    "range",
    "quantiles",
    "lsmean_se",
    "lsmean_ci",
    "lsmean_diffci",
    "pval"
  ),
  summarize_mmrm = c(
    "n",
    "adj_mean_se",
    "adj_mean_ci",
    "adj_mean_est_ci",
    "diff_mean_se",
    "diff_mean_ci",
    "diff_mean_est_ci",
    "change",
    "p_value"
  ),
  tabulate_lsmeans = c(
    "n",
    "adj_mean_se",
    "adj_mean_ci",
    "adj_mean_est_ci",
    "diff_mean_se",
    "diff_mean_ci",
    "diff_mean_est_ci",
    "change",
    "p_value"
  ),
  tabulate_rbmi = c(
    "adj_mean_se",
    "adj_mean_ci",
    "diff_mean_se",
    "diff_mean_ci",
    "change",
    "p_value",
    "additional_title_row"
  ),
  test_proportion_diff = c("pval"),
  a_freq_j = c(
    "n_altdf",
    "n_df",
    "n_rowdf",
    "n_parentdf",
    "denom",
    "count",
    "count_unique",
    "count_unique_fraction",
    "count_unique_denom_fraction"
  ),
  a_patyrs_j = c("patyrs"),
  a_eair100_j = c("eair", "n_event", "person_years")
)

# junco_default_formats ---------------------------------------------------------
junco_default_formats_start <- c(
  adj_mean_se = jjcsformat_xx("xx.xxx (xx.xxx)"),
  adj_mean_ci = jjcsformat_xx("(xx.xxx, xx.xxx)"),
  adj_mean_est_ci = jjcsformat_xx("xx.xxx (xx.xxx, xx.xxx)"),
  change = "xx.x%",
  diff = jjcsformat_xx("xx.x"),
  diff_ci = jjcsformat_xx("(xx.x, xx.x)"),
  diff_est_ci = jjcsformat_xx("xx.x (xx.x, xx.x)"),
  diff_mean_se = jjcsformat_xx("xx.xxx (xx.xxx)"),
  diff_mean_ci = jjcsformat_xx("(xx.xxx, xx.xxx)"),
  diff_mean_est_ci = jjcsformat_xx("xx.xxx (xx.xxx, xx.xxx)"),
  event_free_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  event_free_rate = jjcsformat_xx("xx.xx"),
  hr = jjcsformat_xx("xx.xx"),
  hr_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  hr_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  quantiles_upper = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  lsmean = jjcsformat_xx("xx.xx"),
  lsmean_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  lsmean_diff = jjcsformat_xx("xx.xx"),
  lsmean_diffci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  lsmean_diff_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  lsmean_se = jjcsformat_xx("xx.xx (xx.xx)"),
  mean_sd = jjcsformat_xx("xx.xx (xx.xxx)"),
  median = jjcsformat_xx("xx.xx"),
  median_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  median_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  n = jjcsformat_xx("xx."),
  n_tot = jjcsformat_xx("xx."),
  n_tot_events = jjcsformat_xx("xx."),
  or_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
  pt_at_risk = "xx",
  pval = jjcsformat_pval_fct(0),
  pvalue = jjcsformat_pval_fct(0),
  p_value = jjcsformat_pval_fct(0),
  quantiles = jjcsformat_xx("xx.xx, xx.xx"),
  range = jjcsformat_xx("xx.xx, xx.xx"),
  range_with_cens_info = jjcsformat_range_fct("xx.xx"),
  rate_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  rate_se = jjcsformat_xx("xx.xx"),
  rel_risk_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
  quantiles_upper = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  n_altdf = "xx",
  n_df = "xx",
  n_rowdf = "xx",
  n_parentdf = "xx",
  denom = "xx",
  count = "xx",
  count_unique = "xx",
  count_unique_fraction = jjcsformat_count_fraction,
  count_unique_denom_fraction = jjcsformat_count_denom_fraction,
  rr_ci_3d = jjcsformat_xx("xx.x (xx.x, xx.x)"),
  patyrs = jjcsformat_xx("xx.x"),
  eair = jjcsformat_xx("xx.x"),
  eair_diff = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  n_event = "xx",
  person_years = jjcsformat_xx("xx.xx"),
  total_subject_years = jjcsformat_xx("xx.x (xx.x)")
)

tern_formats_only <- setdiff(names(tern_default_formats), names(junco_default_formats_start))
#' @describeIn default_stats_formats_labels Named vector of default formats for `junco`.
#'
#' @format
#' * `junco_default_formats` is a named vector of available default formats, with each element
#'   named for their corresponding statistic.
#'
#' @export
junco_default_formats <- c(junco_default_formats_start, tern_default_formats[tern_formats_only])

# junco_default_labels ----------------------------------------------------------
junco_default_labels_start <- c(
  additional_title_row = "Additional Title",
  adj_mean_se = "Adjusted Mean (SE)",
  adj_mean_est_ci = "Adjusted Mean (CI)",
  diff = "Difference in Response rate (%)",
  diff_mean_se = "Difference in Adjusted Means (SE)",
  diff_mean_est_ci = "Difference in Adjusted Means (CI)",
  hr = "Hazard Ratio",
  lr_stat_df = "Log-Rank Chi-Squared",
  mean_sd = "Mean (SD)",
  median = "Median",
  n_tot = "Total n",
  n_tot_events = "Total events",
  pval = "p-value",
  pvalue = "p-value",
  p_value = "p-value",
  range = "Min, max",
  range_with_cens_info = "Min, max",
  n_altdf = "N",
  n_df = "N",
  n_rowdf = "N",
  n_parentdf = "N",
  denom = "N",
  patyrs = "Patient years",
  n_event = "Number of events",
  person_years = "Person years",
  total_subject_years = "Total treatment (subject years)"
)
tern_labels_only <- setdiff(names(tern_default_labels), names(junco_default_labels_start))

#' @describeIn default_stats_formats_labels Named `character` vector of default labels for `junco`.
#'
#' @format
#' * `junco_default_labels` is a named `character` vector of available default labels, with each element
#'   named for their corresponding statistic.
#'
#' @export
junco_default_labels <- c(junco_default_labels_start, tern_default_labels[tern_labels_only])

#' @describeIn default_stats_formats_labels Named `integer` vector of default indents for `junco`.
#'
#' @format
#' * `junco_default_indents` is a named `integer` vector of available default indents, with each element
#'   named for their corresponding statistic. Only indentations different from zero need to be
#'   recorded here.
#'
#' @export
junco_default_indents <- c(
  additional_title_row = 1L,
  adj_mean_ci = 1L,
  adj_mean_est_ci = 1L,
  change = 1L,
  diff_ci = 1L,
  diff_mean_ci = 1L,
  diff_mean_est_ci = 1L,
  hr_ci = 1L,
  or_ci = 1L,
  pval = 1L,
  p_value = 1L,
  rate_se = 1L,
  rate_ci = 1L,
  rel_risk_ci = 1L
)

#' @name remove_col_count
#'
#' @title Removal of Unwanted Column Counts
#'
#' @description
#' Remove the N=xx column headers for specified span_label_var columns - default is 'rrisk_header
#' @details This works for only the lowest level of column splitting (since colcounts is used)
#' @param obj table tree object
#' @param span_label_var the spanning header text variable value for which column headers will be removed from
#'
#' @return table tree object with column counts in specified columns removed
#' @export
#'
remove_col_count <- function(obj, span_label_var = "rrisk_header") {
  ## programatically figure out which ones we want
  unwanted_count <- function(pth) pth[1] == span_label_var
  to_blank <- sapply(col_paths(obj), unwanted_count)
  col_counts(obj)[to_blank] <- NA_integer_
  return(obj)
}

h_get_eair_df <- function(levii, df, denom_df, .var, id, occ_var, occ_dy, fup_var) {
  dfii <- df[df[[.var]] == levii & !is.na(df[[.var]]), ]

  df_denom <- unique(denom_df[, c(id, fup_var)])
  df_num <- subset(dfii, dfii[[occ_var]] == "Y")[, c(id, .var, occ_var, occ_dy)]

  ### construct modified fup var subjects not in numerator - use fup_var from df_denom
  df_denom$mod_fup_var <- df_denom[[fup_var]]

  ### add vars from df_num onto df_denom
  df_denom <- dplyr::left_join(df_denom, df_num, by = id)

  # subjects in numerator dataset, use occ_dy variable/365.25
  id_to_update <- df_denom[[id]] %in% df_num[[id]]
  df_denom[id_to_update, "mod_fup_var"] <- df_denom[id_to_update, occ_dy] / 365.25

  return(list(df_denom = df_denom, df_num = df_num))
}

extract_x_stats <- function(list_with_stats, stat_nms) {
  sapply(
    stat_nms,
    function(stat) {
      sapply(
        names(list_with_stats),
        function(x) {
          list_with_stats[[x]][[stat]]
        },
        simplify = FALSE
      )
    },
    simplify = FALSE
  )
}

#' Extract the left-hand side of a formula
#'
#' @keywords internal
leftside <- function(x) {
  checkmate::assert_formula(x)
  res <- x[[2L]]
  checkmate::assert_string(res)
  res
}

#' Custom unlist function
#'
#' Unlist a list, but retain `NULL` as `'NULL'` or `NA`.
#'
#' @keywords internal
.unlist_keep_nulls <- function(lst, null_placeholder = "NULL", recursive = FALSE) {
  lapply(lst, function(x) if (is.null(x)) null_placeholder else x) |>
    unlist(recursive = recursive)
}


#' Title Case Conversion
#'
#' @param x Input string
#' @return String converted to title case (first letter of each word capitalized)
#' @export
#' @keywords internal
string_to_title <- function(x) {
  gsub("(^|\\s)(\\w)", "\\1\\U\\2", x, perl = TRUE)
}

#' Simple Content Row Function to Count Rows
#'
#' @keywords internal
c_row_counts <- function(df, labelstr, label_fstr) {
  in_rows(count = nrow(df), .formats = "xx", .labels = sprintf(label_fstr, labelstr))
}

#' Simple Content Row Function to Count Rows from Alternative Data
#'
#' @keywords internal
c_row_counts_alt <- function(df, labelstr, label_fstr, .alt_df) {
  c_row_counts(df = .alt_df, labelstr = labelstr, label_fstr = label_fstr)
}

#' Layout Creating Function Adding Row Counts
#'
#' This is a simple wrapper of [rtables::summarize_row_groups()] and the main
#' additional value is that we can choose whether we want to use the alternative
#' (usually ADSL) data set for the counts (default) or use the original data set.
#'
#' @inheritParams proposal_argument_convention
#' @param label_fstr (`string`)\cr a `sprintf` style format string.
#'   It can contain up to one `%s` which takes the current split value and
#'   generates the row label.
#' @param alt_counts (`flag`)\cr whether row counts should be taken from
#'   `alt_counts_df` (`TRUE`) or from `df` (`FALSE`).
#'
#' @return A modified layout where the latest row split now contains the counts.
#' @export
#' @examples
#' basic_table() |>
#'   split_cols_by('ARM') |>
#'   add_colcounts() |>
#'   split_rows_by('RACE', split_fun = drop_split_levels) |>
#'   summarize_row_counts(label_fstr = 'RACE value - %s') |>
#'   analyze('AGE', afun = list_wrap_x(summary), format = 'xx.xx') |>
#'   build_table(DM, alt_counts_df = rbind(DM, DM))
#'
summarize_row_counts <- function(lyt, label_fstr = "%s", alt_counts = TRUE) {
  checkmate::assert_flag(alt_counts)

  summarize_row_groups(
    lyt,
    cfun = if (alt_counts) c_row_counts_alt else c_row_counts,
    extra_args = list(label_fstr = label_fstr)
  )
}

#' Unicode Mapping Table
#'
#' A tibble that maps special characters to their Unicode equivalents.
#'
#' @format A tibble with columns 'pattern' and 'unicode', where 'pattern' contains
#' the string to be replaced and 'unicode' contains the Unicode code point in hexadecimal.
#'
#' @export
jj_uc_map <- tibble::tribble(~pattern, ~unicode, ">=", "2265", "<=", "2264")

unicodify <- function(strs, uc_map) {
  out <- strs
  for (i in seq_len(nrow(uc_map))) {
    out <- gsub(uc_map$pattern[i], intToUtf8(strtoi(uc_map$unicode[i], base = 16)), out)
  }
  out
}

#' Shortcut Layout Function for Standard Continuous Variable Analysis
#'
#' @inheritParams proposal_argument_convention
#' @param formats (`list`)\cr formats including `mean_sd`, `median` and `range`
#'   specifications.
#'
#' @note This is used in `tefmad01` and `tefmad03a` e.g.
#' @return Modified layout.
#' @export
analyze_values <- function(lyt, vars, ..., formats) {
  checkmate::assert_list(formats)
  checkmate::assert_names(names(formats), must.include = c("mean_sd", "median", "range"))

  analyze_vars(
    lyt,
    vars = vars,
    ...,
    .stats = c("n", "mean_sd", "median", "range"),
    .formats = c(n = "xx", mean_sd = formats$mean_sd, median = formats$median, range = formats$range),
    .labels = c(n = "N", mean_sd = "Mean (SD)", median = "Median", range = "Min, Max"),
    .indent_mods = c(n = 0, mean_sd = 1, median = 1, range = 1)
  )
}

1		postfun_cog <- function(ret, spl, fulldf, .spl_context,
2		var_names = c("AVAL", "CHG", "BASE"),
3		stats = list(
4		main = c(N = "N", mean = "Mean", SD = "SD", SE = "SE", Med = "Med", Min = "Min", Max = "Max"),
5		base = c(mean = "Mean")
6		)) {
7	2x	all_expr <- expression(TRUE)
8	2x	colset <- .spl_context[nrow(.spl_context), "value"][[1]]
9
10		# Check if colset is one of the main variables (default: AVAL or CHG)
11	2x	if (colset == var_names[1] \|\| colset == var_names[2]) {
12		# Create vectors for make_split_result
13	1x	values <- stats$main
14	1x	labels <- stats$main
15
16		# Create datasplit and subset_exprs lists with the same length as values
17	1x	datasplit <- replicate(length(values), fulldf, simplify = FALSE)
18	1x	names(datasplit) <- names(values)
19
20	1x	subset_exprs <- replicate(length(values), all_expr, simplify = FALSE)
21
22	1x	ret <- rtables::make_split_result(
23	1x	values = values,
24	1x	labels = labels,
25	1x	datasplit = datasplit,
26	1x	subset_exprs = subset_exprs
27		)
28	1x	} else if (colset == var_names[3]) { # Default: BASE
29		# For base variable, use base stats
30	!	values <- stats$base
31	!	labels <- stats$base
32	!	if (names(values)[1] == "mean") {
33		# Keep backward compatibility by adding "Base " prefix to the first label if it's "mean"
34	!	labels[1] <- paste("Base", labels[1])
35		}
36
37		# Create datasplit and subset_exprs lists with the same length as values
38	!	datasplit <- replicate(length(values), fulldf, simplify = FALSE)
39	!	names(datasplit) <- names(values)
40
41	!	subset_exprs <- replicate(length(values), all_expr, simplify = FALSE)
42
43	!	ret <- rtables::make_split_result(
44	!	values = values,
45	!	labels = labels,
46	!	datasplit = datasplit,
47	!	subset_exprs = subset_exprs
48		)
49		} else {
50	1x	stop("something bad happened :(")
51		}
52	1x	ret
53		}
54
55		postfun_eq5d <- function(ret, spl, fulldf, .spl_context) {
56	4x	all_expr <- expression(TRUE)
57	4x	colset <- .spl_context[nrow(.spl_context), "value"][[1]]
58	4x	if (colset == "AVAL") {
59	1x	ret <- make_split_result(
60	1x	values = c(N = "N", mean = "Mean", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
61	1x	labels = c(N = "N", mean = "Mean", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
62	1x	datasplit = list(N = fulldf, mean = fulldf, SD = fulldf, Med = fulldf, Min = fulldf, Max = fulldf),
63	1x	subset_exprs = list(all_expr, all_expr, all_expr, all_expr, all_expr, all_expr)
64		)
65	3x	} else if (colset == "BASE") {
66	1x	ret <- make_split_result(
67	1x	values = c(mean_sd = "mean_sd"),
68	1x	labels = c(mean_sd = "Base Mean (SD)"),
69	1x	datasplit = list(mean_sd = fulldf),
70	1x	subset_exprs = list(all_expr)
71		)
72	2x	} else if (colset == "CHG") {
73	1x	ret <- make_split_result(
74	1x	values = c(N = "N", mean = "Mean", SE = "SE", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
75	1x	labels = c(N = "N", mean = "Mean", SE = "SE", SD = "SD", Med = "Med", Min = "Min", Max = "Max"),
76	1x	datasplit = list(N = fulldf, mean = fulldf, SE = fulldf, SD = fulldf, Med = fulldf, Min = fulldf, Max = fulldf),
77	1x	subset_exprs = list(all_expr, all_expr, all_expr, all_expr, all_expr, all_expr, all_expr)
78		)
79		} else {
80	1x	stop("something bad happened :(")
81		}
82	3x	ret
83		}
84
85		calc_one_visit <- function(datvec, decimal, statnm, visit, varnm, roundmethod = c("sas", "iec"), exclude_visits,
86		var_names = c("AVAL", "CHG", "BASE")) {
87	26x	roundmethod <- match.arg(roundmethod)
88	26x	if (is.na(decimal)) {
89	!	decimal <- 0
90		}
91	26x	if ((varnm == var_names[2] \|\| varnm == var_names[3]) && (visit %in% exclude_visits)) {
92	2x	return(NULL)
93		}
94	24x	if (roundmethod == "sas") {
95	23x	switch(statnm,
96	2x	N = length(stats::na.omit(datvec)),
97	3x	SE = format(
98	3x	tidytlg::roundSAS(stats::sd(datvec) / sqrt(length(stats::na.omit(datvec))), decimal + 2),
99	3x	nsmall = decimal + 2
100		),
101	3x	SD = format(
102	3x	tidytlg::roundSAS(stats::sd(datvec), decimal + 2),
103	3x	nsmall = decimal +
104	3x	2
105		),
106	6x	Mean = format(tidytlg::roundSAS(mean(datvec), decimal + 1), nsmall = decimal + 1),
107	!	mean_sd = paste0(
108	!	format(tidytlg::roundSAS(mean(datvec), decimal + 1), nsmall = decimal + 1),
109		" (",
110	!	format(
111	!	tidytlg::roundSAS(stats::sd(datvec), decimal + 2),
112	!	nsmall = decimal +
113	!	2
114		),
115		")"
116		),
117	3x	Med = format(tidytlg::roundSAS(stats::median(datvec), decimal + 1), nsmall = decimal + 1),
118	3x	Min = format(tidytlg::roundSAS(min(datvec), decimal), nsmall = decimal),
119	3x	Max = format(tidytlg::roundSAS(max(datvec), decimal), nsmall = decimal)
120		)
121		} else {
122	1x	switch(statnm,
123	!	N = length(stats::na.omit(datvec)),
124	!	SE = format(round(stats::sd(datvec) / sqrt(length(stats::na.omit(datvec))), decimal + 2), nsmall = decimal + 2),
125	!	SD = format(round(stats::sd(datvec), decimal + 2), nsmall = decimal + 2),
126	1x	Mean = format(round(mean(datvec), decimal + 1), nsmall = decimal + 1),
127	!	mean_sd = paste0(
128	!	format(round(mean(datvec), decimal + 1), nsmall = decimal + 1),
129		" (",
130	!	format(
131	!	round(stats::sd(datvec), decimal + 2),
132	!	nsmall = decimal +
133	!	2
134		),
135		")"
136		),
137	!	Med = format(round(stats::median(datvec), decimal + 1), nsmall = decimal + 1),
138	!	Min = format(round(min(datvec), decimal), nsmall = decimal),
139	!	Max = format(round(max(datvec), decimal), nsmall = decimal)
140		)
141		}
142		}
143
144		#' @name column_stats
145		#' @title Statistics within the column space
146		#' @description
147		#' A function used for obtaining statistics within the columns of your table. Used in change from baseline tables.
148		#' This takes the visit names as its row labels.
149		#' @param exclude_visits Vector of visit(s) for which you do not want the statistics displayed
150		#' in the baseline mean or change from baseline sections of the table.
151		#' @param var_names Vector of variable names to use instead of the default AVAL, CHG, BASE.
152		#' The first two elements are treated as main variables with full statistics, and the third element
153		#' is treated as the base variable. By default, the function expects these specific variable names in your data,
154		#' but you can customize them to match your dataset's column names.
155		#' @param stats A list with two components, `main` and `base`, that define the statistics to be calculated
156		#' for the main variables (default: AVAL, CHG) and the base variable (default: BASE).
157		#' Default for main variables: c(N = "N", mean = "Mean", SD = "SD", SE = "SE", Med = "Med", Min = "Min", Max = "Max")
158		#' Default for base variable: c(mean = "Mean")
159		#' You can customize these statistics by providing your own named vectors in the list. The names are used
160		#' internally for calculations, and the values are used as display labels in the table.
161		#' @export
162		column_stats <- function(exclude_visits = c("Baseline (DB)"),
163		var_names = c("AVAL", "CHG", "BASE"),
164		stats = list(
165		main = c(
166		N = "N", mean = "Mean", SD = "SD", SE = "SE",
167		Med = "Med", Min = "Min", Max = "Max"
168		),
169		base = c(mean = "Mean")
170		)) {
171	8x	function(df, .var, .spl_context) {
172	8x	allcolsplvals <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
173	8x	statnm <- utils::tail(allcolsplvals, 1)
174	8x	varnm <- allcolsplvals[length(allcolsplvals) - 1]
175	8x	datvec <- df[[varnm]]
176	8x	decimalp <- utils::tail(df$dp, 1)
177	8x	datpervis <- split(datvec, df[[.var]]) ## ,var is AVISIT
178	8x	in_rows(
179	8x	.list = mapply(
180	8x	calc_one_visit,
181	8x	datvec = datpervis,
182	8x	decimal = decimalp,
183	8x	visit = names(datpervis),
184	8x	MoreArgs = list(
185	8x	statnm = statnm,
186	8x	varnm = varnm,
187	8x	exclude_visits = exclude_visits,
188	8x	var_names = var_names
189		)
190		),
191	8x	.names = names(datpervis)
192		)
193		}
194		}
195
196		calc_N <- function(datvec, statnm, trt, varnm) {
197	3x	if (varnm != "AVAL") {
198	1x	return(NULL)
199		}
200	2x	length(stats::na.omit(datvec))
201		}
202
203		column_N <- function(df, .var, .spl_context, id = "USUBJID", var_names = c("AVAL", "CHG", "BASE")) {
204	1x	allcolsplvals <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
205	1x	statnm <- utils::tail(allcolsplvals, 1)
206	1x	varnm <- allcolsplvals[length(allcolsplvals) - 1]
207	1x	datvec <- unique(df[[id]])
208	1x	datpertrt <- split(datvec, df[[.var]]) ## ,var is Treatment
209	1x	in_rows(
210	1x	.list = mapply(calc_N, datvec = datpertrt, trt = names(datpertrt), MoreArgs = list(statnm = statnm, varnm = varnm)),
211	1x	.names = names(datpertrt)
212		)
213		}

1		#' @title Create TableTree as DataFrame via gentlg
2		#'
3		#' @param tt TableTree object to convert to a data frame
4		#' @param fontspec Font specification object
5		#' @param string_map Unicode mapping for special characters
6		#' @param markup_df Data frame containing markup information
7		tt_to_tbldf <- function(
8		tt,
9		fontspec = font_spec("Times", 9L, 1),
10		string_map = default_str_map,
11		markup_df = dps_markup_df
12		) {
13	24x	if (!validate_table_struct(tt)) {
14	!	stop(
15	!	"invalid table structure. summarize_row_groups without ",
16	!	"analyze below it in layout structure?"
17		)
18		}
19	24x	mpf <- matrix_form(
20	24x	tt,
21	24x	indent_rownames = FALSE,
22	24x	expand_newlines = FALSE,
23	24x	fontspec = fontspec
24		)
25
26	24x	strmat <- mf_strings(mpf)
27	24x	strmat[, 1] <- gsub("^[[:space:]]+", "", strmat[, 1])
28	24x	nhl <- mf_nlheader(mpf)
29	24x	strbody <- strmat[-(1:nhl), , drop = FALSE]
30	24x	row_type <- apply(
31	24x	strbody,
32	24x	1,
33	24x	function(x) {
34	339x	nonempty <- nzchar(x)
35	339x	if (all(!nonempty)) {
36		## shouldn't ever happen
37	!	"EMPTY"
38	339x	} else if (nonempty[1] && all(!nonempty[-1])) {
39		# only 1st cell nonempty
40	!	"HEADER"
41		} else {
42	339x	if (x[1] == "N") {
43	!	"N"
44		} else {
45	339x	"VALUE"
46		}
47		}
48		}
49		)
50	24x	rowdf <- mf_rinfo(mpf)
51	24x	rinds <- mf_lgrouping(mpf)[-(1:nhl)] -
52	24x	mf_nrheader(mpf)
53	24x	indentme <- rowdf$indent[rinds]
54	24x	anbr <- cumsum(!is.na(c(0, utils::head(rowdf$trailing_sep, -1))))[rinds] + 1 ## so it starts at 1
55	24x	roworder <- seq_len(NROW(rowdf)) - (anbr - 1)
56	24x	newrows <- c(0, ifelse(utils::tail(anbr, -1) == utils::head(anbr, -1), 0, 1))
57
58	24x	strbody <- prep_strs_for_rtf(strbody, string_map, markup_df)
59	24x	tbldf <- as.data.frame(strbody)
60
61	24x	names(tbldf) <- c("label", paste("col", seq_len(ncol(tbldf) - 1)))
62	24x	emptycols <- tbldf[1, ]
63	24x	emptycols[1, ] <- ""
64
65	24x	tbldf <- cbind(
66	24x	tbldf,
67	24x	data.frame(
68	24x	row_type = row_type,
69	24x	anbr = anbr,
70	24x	indentme = indentme,
71	24x	roworder = roworder,
72	24x	newrows = newrows,
73	24x	stringsAsFactors = FALSE
74		)
75		)
76	24x	tbldf
77		}
78
79		brackets_to_rtf <- function(strs) {
80	!	gsub("\\[\\[([^]]+)\\]\\]", "\\\\{\\1}", strs)
81		}
82
83		gutter_width <- .12 # inches
84
85		## this is for Times New Roman 9
86		mar_plus_gutters <- 2 + gutter_width
87
88		pg_width_by_orient <- function(landscape = FALSE) {
89	23x	fullpg <- ifelse(landscape, 11, 8.5)
90	23x	fullpg - mar_plus_gutters
91		}
92
93		tlg_type <- function(tt) {
94	13x	if (methods::is(tt, "list") && !methods::is(tt, "listing_df")) {
95	!	tt <- tt[[1]]
96		}
97	13x	if (methods::is(tt, "ggplot")) {
98	!	ret <- "Figure"
99	13x	} else if (methods::is(tt, "VTableTree")) {
100	11x	ret <- "Table"
101	2x	} else if (methods::is(tt, "listing_df")) {
102	2x	ret <- "Listing"
103		} else {
104	!	stop(
105	!	"unable to determine tlg type for object of class: ",
106	!	paste(class(tt), collapse = ",")
107		)
108		}
109	13x	ret
110		}
111
112		mpf_to_colspan <- function(
113		mpf,
114		string_map = default_str_map,
115		markup_df = dps_markup_df
116		) {
117	25x	if (!methods::is(mpf, "MatrixPrintForm")) {
118	!	stop("figure out how to make this an mpf (MatrixPrintForm) first.")
119		}
120	25x	strmat <- mf_strings(mpf)
121		## spaces in column header will get underlines, but we dont' want them to
122	25x	nhl <- mf_nlheader(mpf)
123	25x	strmat[seq_len(nhl - 1), ] <- gsub(
124	25x	"^[[:space:]]+$",
125		"",
126	25x	strmat[seq_len(nhl - 1), ]
127		)
128	25x	strmat[nhl, ] <- ifelse(nzchar(strmat[nhl, ]), strmat[nhl, ], " ")
129	25x	strmat <- prep_strs_for_rtf(strmat, string_map, markup_df)
130	25x	nspancols <- nhl - 1L
131	25x	if (nspancols > 0) {
132	21x	csph <- lapply(seq_len(nspancols), function(ii) {
133	42x	spns <- mf_spans(mpf)[ii, ]
134	42x	vals <- strmat[ii, ]
135	42x	jj <- 1 ## could start at 2 cause 1 is row label/topleft space but why complicate thigns
136	42x	ind <- 1
137	42x	myrle <- rle(vals)
138	42x	while (jj < length(vals)) {
139	93x	if (myrle$lengths[ind] == 1) {
140	42x	jj <- jj + 1
141	42x	ind <- ind + 1
142		} else {
143	51x	sq <- seq(jj, jj + myrle$lengths[ind] - 1)
144	51x	valspns <- spns[sq]
145	51x	if (valspns[1] != length(sq)) {
146	!	vals[sq] <- split_val_spans(vals[jj], valspns)
147		}
148	51x	jj <- tail(sq, 1) + 1
149	51x	ind <- ind + 1
150		}
151		}
152	42x	vals
153		})
154		} else {
155	4x	csph <- NULL
156		}
157
158	25x	list(colspan = csph, colheader = strmat[nhl, ])
159		}
160
161		split_val_spans <- function(val, spns) {
162	!	if (val == "") {
163	!	return(rep(val, length(spns)))
164		}
165	!	padvec <- rep("", length(spns))
166	!	j <- 1
167	!	padnum <- 0
168	!	while (j < length(spns)) {
169	!	onespn <- spns[j]
170	!	if (padnum > 0) {
171	!	padvec[j:(j + onespn - 1)] <- strrep(" ", padnum)
172		}
173	!	padnum <- padnum + 1
174	!	j <- j + onespn
175		}
176	!	paste0(padvec, val, padvec)
177		}
178
179		partmpf_to_colinds <- function(fullmpf, partmpf) {
180	17x	stopifnot(
181	17x	mf_nlheader(fullmpf) == mf_nlheader(partmpf),
182	17x	mf_ncol(fullmpf) >= mf_ncol(partmpf)
183		)
184	17x	nlh <- mf_nlheader(fullmpf)
185	17x	fullhdr <- mf_strings(fullmpf)[1:nlh, , drop = FALSE]
186	17x	parthdr <- mf_strings(partmpf)[1:nlh, , drop = FALSE]
187	17x	fullkeys <- apply(fullhdr, 2, paste, collapse = "", simplify = TRUE)
188		## hack to force first key to match uniquely
189	17x	fullkeys[1] <- paste(c("xxx", fullkeys[-1]), collapse = "")
190	17x	stopifnot(length(fullkeys) == length(unique(fullkeys)))
191	17x	partkeys <- apply(parthdr, 2, paste, collapse = "", simplify = TRUE)
192	17x	partkeys[1] <- fullkeys[1]
193	17x	match(partkeys, fullkeys)
194		}
195
196		subset_border_mat <- function(full_brdr, full_mpf, part_mpf) {
197	17x	if (is.null(full_brdr)) {
198	!	return(NULL)
199		}
200	17x	inds <- partmpf_to_colinds(full_mpf, part_mpf)
201	17x	full_brdr[, inds, drop = FALSE]
202		}
203
204
205		get_ncol <- function(tt) {
206	1x	if (is(tt, "listing_df") \|\| is(tt, "VTableTree"))
207	1x	ncol(tt)
208	!	else if (is(tt, "MatrixPrintForm"))
209	!	mf_ncol(tt)
210	!	else if (is.list(tt)) {
211	!	if (is(tt[[1]], "MatrixPrintForm"))
212	!	mf_ncol(tt[[1]])
213		else
214	!	ncol(tt[[1]])
215		}
216		}
217
218		#' @name tt_to_tlgrtf
219		#' @title TableTree to .rtf Conversion
220		#' @description
221		#' A function to convert TableTree to .rtf
222		#' @details
223		#' This function aids in converting the rtables TableTree into the desired .rtf file.
224		#'
225		#' @param tt TableTree object to convert to RTF
226		#' @param file character(1). File to create, including path, but excluding
227		#' .rtf extension.
228		#' @param orientation Orientation of the output ("portrait" or "landscape")
229		#' @param colwidths Column widths for the table
230		#' @param label_width_ins Label width in inches
231		#' @param fontspec Font specification object
232		#' @param pg_width Page width in inches
233		#' @param margins Margins in inches (top, right, bottom, left)
234		#' @param paginate Whether to paginate the output
235		#' @param col_gap Column gap in spaces
236		#' @param verbose Whether to print verbose output
237		#' @param tlgtype Type of the output (Table, Listing, or Figure)
238		#' @param string_map Unicode mapping for special characters
239		#' @param markup_df Data frame containing markup information
240		#' @param ... Additional arguments passed to gentlg
241		#' @inheritParams tidytlg::gentlg
242		#' @param nosplitin list(row=, col=). Path elements whose children should not be paginated within
243		#' if it can be avoided. e.g., list(col="TRT01A") means don't split within treatment arms unless
244		#' all the associated columns don't fit on a single page.
245		#' @param combined_rtf logical(1). In the case where the result is broken up into multiple
246		#' parts due to width, should a combined rtf file also be created. Defaults to `FALSE`.
247		#' @param one_table logical(1). If `tt` is a (non-`MatrixPrintForm`) list,
248		#' should the parts be added to the rtf within a single table (`TRUE`, the
249		#' default) or as separate tables. End users will not generally need to set this.
250		#' @param border_mat matrix. A `m x k` matrix where m is the number of columns of `tt`
251		#' and k is the number of lines the header takes up. See [tidytlg::add_bottom_borders]
252		#' for what the matrix should contain. Users should only specify this when the
253		#' default behavior does not meet their needs.
254		#' @import rlistings
255		#' @rdname tt_to_tlgrtf
256		#' @export
257		#' @seealso Used in all table and listing scripts
258		#' @note `file` should always include path. Path will be extracted
259		#' and passed separately to `gentlg`.
260		#' @note When `one_table` is `FALSE`, only the width of the row label
261		#' pseudocolumn can be directly controlled due to a limitation in
262		#' `tidytlg::gentlg`. The proportion of the full page that the first value
263		#' in colwidths would take up is preserved and all other columns equally
264		#' split the remaining available width. This will cause, e.g., the
265		#' elements within the allparts rtf generated when `combined_rtf` is `TRUE`
266		#' to differ visually from the content of the individual part rtfs.
267		#'
268		tt_to_tlgrtf <- function(
269		tt,
270		file = file.path(".", tolower(tlg_type(tt))),
271		orientation = c("portrait", "landscape"),
272		colwidths = def_colwidths(
273		tt,
274		fontspec,
275		col_gap = col_gap,
276		label_width_ins = label_width_ins,
277		type = tlgtype
278		),
279		label_width_ins = 2,
280		watermark = NULL,
281		pagenum = ifelse(tlgtype == "Listing", TRUE, FALSE),
282		fontspec = font_spec("Times", 9L, 1.2),
283		pg_width = pg_width_by_orient(orientation == "landscape"),
284		margins = c(0, 0, 0, 0),
285		paginate = tlg_type(tt) == "Table",
286		col_gap = ifelse(tlgtype == "Listing", .5, 3),
287		nosplitin = list(
288		row = character(),
289		col = character()
290		),
291		verbose = FALSE,
292		tlgtype = tlg_type(tt),
293		string_map = default_str_map,
294		markup_df = dps_markup_df,
295		combined_rtf = FALSE,
296		one_table = TRUE,
297		border_mat = make_header_bordmat(obj = tt),
298		...
299		) {
300	24x	orientation <- match.arg(orientation)
301	24x	newdev <- open_font_dev(fontspec)
302	24x	if (newdev) {
303	6x	on.exit(close_font_dev())
304		}
305
306	24x	if (tlgtype == "Listing" && nrow(tt) == 0) {
307	!	dat <- as.list(c("No data to report", rep("", ncol(tt) - 1)))
308	!	names(dat) <- names(tt)
309	!	df <- as.data.frame(dat)
310	!	var_labels(df) <- var_labels(tt)
311
312	!	tt <- as_listing(
313	!	df,
314	!	key_cols = get_keycols(tt),
315	!	disp_cols = listing_dispcols(tt)
316		)
317		}
318
319	24x	if (tlgtype == "Table" && fontspec$size == 8) {
320	!	opts <- options(
321	!	tidytlg.fontsize.table.footnote = 8,
322	!	tidytlg.fontsize.table = 8
323		)
324	!	on.exit(options(opts), add = TRUE)
325		}
326
327	24x	if (length(colwidths) == 1) {
328	1x	nc <- get_ncol(tt)
329	1x	tot_width <- page_lcpp(
330	1x	pg_width = pg_width,
331	1x	pg_height = 20, # don't care about this,
332	1x	font_family = fontspec$family,
333	1x	font_size = fontspec$size,
334	1x	lineheight = fontspec$lineheight,
335	1x	margins = c(0, 0, 0, 0),
336	1x	landscape = orientation == "landscape"
337	1x	)$cpp
338	1x	wdth_left <- tot_width - colwidths
339	1x	colwidths <- c(colwidths, rep(floor(wdth_left / nc), nc))
340		}
341
342	24x	max_lwidth <- inches_to_spaces(label_width_ins, fontspec)
343	24x	if (colwidths[1] > max_lwidth) {
344	1x	colwidths[1] <- max_lwidth
345		}
346
347	24x	if (!requireNamespace("tidytlg")) {
348	!	stop("tidytlg not installed, cannot go out to rtf.")
349		}
350
351	24x	if (paginate) {
352		## implies type Table
353	5x	if (tlgtype != "Table") {
354	!	stop(
355	!	"pagination is not currently supported for tlg types other than Table."
356		)
357		}
358	5x	if (methods::is(tt, "VTableTree")) {
359	5x	hdrmpf <- matrix_form(tt[1, ])
360	!	} else if (methods::is(tt, "list") && methods::is(tt[[1]], "MatrixPrintForm")) {
361	!	hdrmpf <- tt[[1]]
362		} else {
363	!	hrdmpf <- tt
364		}
365	5x	pags <- paginate_to_mpfs(
366	5x	tt,
367	5x	fontspec = fontspec,
368	5x	landscape = orientation == "landscape",
369	5x	colwidths = colwidths,
370	5x	col_gap = col_gap,
371	5x	pg_width = pg_width,
372	5x	pg_height = NULL,
373	5x	margins = margins,
374	5x	lpp = NULL,
375	5x	nosplitin = nosplitin,
376	5x	verbose = verbose
377		) ##
378	5x	if (has_force_pag(tt)) {
379	!	nslices <- which(
380	!	cumsum(vapply(pags, mf_ncol, 1L)) == ncol(tt)
381		)
382	!	oldpags <- pags
383	!	pags <- lapply(
384	!	seq_len(nslices),
385	!	function(ii) {
386	!	inds <- seq(ii, by = nslices, length.out = length(oldpags) / nslices)
387	!	oldpags[inds]
388		}
389		)
390		}
391	5x	pag_bord_mats <- lapply(
392	5x	seq_along(pags),
393	5x	function(i) {
394	17x	if (methods::is(pags[[i]], "MatrixPrintForm")) {
395	17x	partmpf <- pags[[i]]
396		} else {
397	!	partmpf <- pags[[i]][[1]]
398		}
399	17x	subset_border_mat(border_mat, hdrmpf, partmpf)
400		}
401		)
402	5x	ret <- lapply(
403	5x	seq_along(pags),
404	5x	function(i) {
405	17x	if (length(pags) > 1) {
406	14x	fmti <- paste0("%0", ceiling(log(length(pags), base = 10)), "d")
407	14x	fname <- paste0(file, "part", sprintf(fmti, i), "of", length(pags))
408		} else {
409	3x	fname <- file
410		}
411	17x	full_pag_i <- pags[[i]]
412	5x	if (
413	17x	is.list(full_pag_i) &&
414	17x	!methods::is(full_pag_i, "MatrixPrintForm")
415		) {
416	!	pgi_for_cw <- full_pag_i[[1]]
417		} else {
418	17x	pgi_for_cw <- full_pag_i
419		}
420	17x	tt_to_tlgrtf(
421	17x	full_pag_i,
422	17x	file = fname,
423	17x	orientation = orientation,
424	17x	colwidths = j_mf_col_widths(pgi_for_cw),
425	17x	fontspec = fontspec,
426	17x	watermark = watermark,
427	17x	col_gap = col_gap,
428	17x	paginate = FALSE,
429	17x	tlgtype = tlgtype,
430	17x	string_map = string_map,
431	17x	markup_df = markup_df,
432	17x	border_mat = pag_bord_mats[[i]],
433		...
434		)
435		}
436		)
437	5x	if (combined_rtf) {
438	1x	if (length(pags) > 1) {
439	1x	tt_to_tlgrtf(
440	1x	pags,
441	1x	file = paste0(file, "allparts"),
442	1x	orientation = orientation,
443	1x	fontspec = fontspec,
444	1x	watermark = watermark,
445	1x	col_gap = col_gap,
446	1x	paginate = FALSE,
447	1x	tlgtype = "Table",
448	1x	string_map = string_map,
449	1x	markup_df = markup_df,
450	1x	one_table = FALSE,
451		## gentlg isn't vectorized on column widths so we're SOL here...
452	1x	colwidths = colwidths, ## this is largely ignored see note in docs
453		# colwidths are already on the pags since they are mpfs
454	1x	border_mat = pag_bord_mats,
455		...
456		)
457		} else { # only one page after pagination
458	!	message(
459	!	"Table ",
460	!	basename(file),
461	!	": No combined RTF created, output fit within one part."
462		)
463		}
464		}
465	5x	return(ret)
466		}
467
468	19x	if (tlgtype == "Table") {
469	18x	if (is.list(tt) && !methods::is(tt, "MatrixPrintForm")) {
470	1x	df <- lapply(
471	1x	tt,
472	1x	tt_to_tbldf,
473	1x	fontspec = fontspec,
474	1x	string_map = string_map,
475	1x	markup_df = markup_df
476		)
477	1x	if (one_table) {
478	!	df <- do.call(
479	!	rbind,
480	!	lapply(
481	!	seq_along(df),
482	!	function(ii) {
483	!	dfii <- df[[ii]]
484	!	dfii$newpage <- 0
485	!	if (ii > 1) {
486	!	dfii$newpage[1] <- 1
487		}
488	!	dfii$indentme <- ifelse(dfii$indentme <= 1, 0, dfii$indentme - 1)
489	!	dfii
490		}
491		)
492		)
493		}
494		} else {
495	17x	df <- tt_to_tbldf(
496	17x	tt,
497	17x	fontspec = fontspec,
498	17x	string_map = string_map,
499	17x	markup_df = markup_df
500		)
501		}
502		} else {
503	1x	df <- tt[, listing_dispcols(tt)]
504		}
505
506		## we only care about the col labels here...
507	19x	if (tlgtype == "Table" && is.list(tt) && !methods::is(tt, "MatrixPrintForm")) {
508	1x	mpf <- tt[[1]]
509	1x	if (!one_table) {
510	1x	colinfo <- lapply(
511	1x	tt,
512	1x	mpf_to_colspan,
513	1x	markup_df = markup_df,
514	1x	string_map = string_map
515		)
516	1x	csph <- lapply(colinfo, function(x) x$colspan)
517	1x	colheader <- lapply(colinfo, function(x) x$colheader)
518		} else {
519	!	colinfo <- mpf_to_colspan(
520	!	mpf,
521	!	markup_df = markup_df,
522	!	string_map = string_map
523		)
524	!	csph <- colinfo$colspan
525	!	colheader <- colinfo$colheader
526		}
527	18x	} else if (methods::is(tt, "MatrixPrintForm")) {
528	17x	mpf <- tt
529	17x	colinfo <- mpf_to_colspan(
530	17x	mpf,
531	17x	markup_df = markup_df,
532	17x	string_map = string_map
533		)
534	17x	csph <- colinfo$colspan
535	17x	colheader <- colinfo$colheader
536		} else {
537	1x	mpf <- matrix_form(
538	1x	utils::head(tt, 1),
539	1x	indent_rownames = FALSE,
540	1x	expand_newlines = FALSE,
541	1x	fontspec = fontspec
542		)
543	1x	colinfo <- mpf_to_colspan(
544	1x	mpf,
545	1x	markup_df = markup_df,
546	1x	string_map = string_map
547		)
548	1x	csph <- colinfo$colspan
549	1x	colheader <- colinfo$colheader
550		}
551
552	19x	fname <- basename(file)
553		## dirname on "table" returns "." so we're good using
554		## this unconditionally as opath
555	19x	fpath <- dirname(file)
556
557	19x	if (tlgtype == "Table") {
558	18x	colwidths <- cwidths_final_adj(
559	18x	labwidth_ins = label_width_ins,
560	18x	total_width = pg_width,
561	18x	colwidths = colwidths[-1]
562		)
563		}
564	19x	colwidths <- colwidths / sum(colwidths)
565		# finite precision arithmetic is a dreamscape of infinite wonder...
566		## sum(rep(1/18, 18)) <= 1 is FALSE...
567	19x	if (sum(colwidths) > 1) {
568	!	colwidths <- colwidths - 0.00000000001 ## much smaller than a twip = 1/20 printing point
569		}
570
571	19x	if (!one_table &&
572	19x	is.list(tt) && !is(tt, "MatrixPrintForm") &&
573	19x	length(unique(vapply(tt, ncol, 1))) > 1) {
574		### gentlg is not vectorized on wcol. x.x x.x x.x
575		### but it won't break if we only give it one number...
576		### Calling this an ugly hack is an insult to all the hard working hacks
577		### out there
578	1x	colwidths <- colwidths[1]
579		}
580
581	19x	footer_val <- prep_strs_for_rtf(
582	19x	c(
583	19x	main_footer(mpf),
584	19x	prov_footer(mpf)
585		),
586	19x	string_map,
587	19x	markup_df
588		)
589	19x	if (length(footer_val) == 0) {
590	19x	footer_val <- NULL
591		}
592
593	19x	if (tlgtype == "Table" && is.data.frame(df)) {
594	17x	utils::write.csv(
595	17x	df,
596	17x	file = file.path(fpath, paste0(tolower(fname), ".csv")),
597	17x	row.names = FALSE
598		)
599		}
600
601	19x	tidytlg::gentlg(
602	19x	df,
603	19x	tlf = tlgtype,
604	19x	format = "rtf",
605	19x	idvars = if (tlgtype == "Listing") get_keycols(tt) else NULL,
606	19x	colspan = csph,
607	19x	file = fname,
608	19x	opath = fpath,
609	19x	colheader = colheader,
610	19x	title = prep_strs_for_rtf(
611	19x	main_title(mpf),
612	19x	string_map,
613	19x	markup_df
614		),
615	19x	footers = footer_val,
616	19x	orientation = orientation,
617	19x	wcol = colwidths,
618	19x	watermark = watermark,
619	19x	pagenum = pagenum,
620	19x	bottom_borders = border_mat,
621		...
622		)
623		}
624
625		## NB x/(x+sum(colwidths)) = labwidth_ins/total_width
626		cwidths_final_adj <- function(labwidth_ins, total_width, colwidths) {
627	19x	prop <- labwidth_ins / total_width
628	19x	lwidth <- floor(prop / (1 - prop) * sum(colwidths))
629	19x	c(lwidth, colwidths)
630		}
631
632		muffwarn_fun <- function(w) {
633	!	print("handling warnings")
634	!	if (grepl("grid.Call(C_convert", w, fixed = TRUE)) {
635	!	invokeRestart("muffleWarning")
636		}
637		}
638
639		make_bordmat_row <- function(rowspns) {
640	11x	havespn <- rowspns > 1
641	11x	if (!any(havespn)) {
642	6x	return(rep(0, times = length(rowspns)))
643		}
644
645	5x	pos <- 1
646	5x	ngrp <- 1
647	5x	ret <- numeric(length(rowspns))
648	5x	while (pos < length(rowspns)) {
649	30x	spnval <- rowspns[pos]
650	30x	if (spnval > 1) {
651	26x	multipos <- seq(pos, pos + spnval - 1)
652	26x	val <- ngrp
653		} else {
654	4x	multipos <- pos
655	4x	val <- 0
656		}
657	30x	ret[multipos] <- val
658	30x	pos <- pos + spnval
659	30x	ngrp <- ngrp + 1
660		}
661	5x	ret
662		}
663
664		fixup_bord_mat <- function(brdmat, hstrs) {
665		## no lines between labels and their counts
666	5x	countcells <- matrix(
667	5x	grepl("N=", hstrs, fixed = TRUE),
668	5x	nrow = nrow(hstrs),
669	5x	ncol = ncol(hstrs)
670		)
671
672	5x	countcoords <- which(countcells, arr.ind = TRUE)
673	5x	for (i in seq_len(nrow(countcoords))) {
674	!	brdmat[countcoords[i, "row"] - 1, countcoords[i, "col"]] <- 0
675		}
676
677	5x	brdmat[!nzchar(hstrs) \| hstrs == " "] <- 0
678	5x	brdmat[nrow(brdmat), ] <- 1
679	5x	brdmat[seq_len(nrow(brdmat) - 1), 1] <- 0
680	5x	brdmat
681		}
682
683		.make_header_bordmat <- function(
684		obj,
685		mpf = matrix_form(utils::head(obj, 1), expand_newlines = FALSE)
686		) {
687	5x	spns <- mf_spans(mpf)
688	5x	nlh <- mf_nlheader(mpf)
689	5x	nrh <- mf_nrheader(mpf)
690	5x	stopifnot(nlh == nrh)
691
692	5x	hstrs <- mf_strings(mpf)[seq_len(nrh), , drop = FALSE]
693	5x	spns <- mf_spans(mpf)[seq_len(nrh), , drop = FALSE]
694
695	5x	brdmat <- do.call(
696	5x	rbind,
697	5x	lapply(
698	5x	seq_len(nrh),
699	5x	function(i) make_bordmat_row(spns[i, ])
700		)
701		)
702
703	5x	brdmat <- fixup_bord_mat(brdmat, hstrs)
704	5x	brdmat
705		}
706
707		setGeneric(
708		"make_header_bordmat",
709		function(
710		obj,
711		mpf = matrix_form(utils::head(obj, 1), expand_newlines = FALSE)
712		) {
713	11x	standardGeneric("make_header_bordmat")
714		}
715		)
716
717		setMethod(
718		"make_header_bordmat",
719		c(obj = "ANY", mpf = "MatrixPrintForm"),
720		.make_header_bordmat
721		)
722
723		setMethod(
724		"make_header_bordmat",
725		c(obj = "listing_df"),
726		function(obj, mpf) matrix(1, nrow = 1, ncol = length(listing_dispcols(obj)))
727		)
728
729		setMethod(
730		"make_header_bordmat",
731		c(obj = "VTableTree", mpf = "missing"),
732		function(obj, mpf) {
733	5x	make_header_bordmat(
734	5x	mpf = matrix_form(
735	5x	utils::head(obj, 1),
736	5x	expand_newlines = FALSE
737		)
738		)
739		}
740		)

1		#' @name jj_complex_scorefun
2		#' @title Complex Scoring Function
3		#' @description
4		#' A function used for sorting AE tables (and others) as required.
5		#' @details
6		#' This sort function sorts as follows:
7		#' Takes all the columns from a specified spanning column header (default= colspan_trt) and sorts by the last treatment
8		#' column within this.
9		#' If no spanning column header variable exists (e.g you have only one active treatment arm and have decided to
10		#' remove the spanning header from your layout) it will sort by the first treatment column in your table.
11		#' This function is not really designed for tables that have sub-columns, however if users wish to override any
12		#' default sorting behavior, they can simply specify their own colpath to use for sorting on (default=NULL)
13		#' @param spanningheadercolvar name of spanning header variable that defines the active treatment columns.
14		#' If you do not have an active treatment spanning header column then user can define this as NA.
15		#' @param usefirstcol This allows you to just use the first column of the table to sort on.
16		#' @param colpath name of column path that is needed to sort by (default=NULL).
17		#' This overrides other arguments if specified
18		#' (except firstcat and lastcat which will be applied if requested on this colpath)
19		#' @param firstcat If you wish to put any category at the top of the list despite any n's user can specify here.
20		#' @param lastcat If you wish to put any category at the bottom of the list despite any n's user can specify here.
21		#' @export
22		#' @returns a function which can be used as a score function (scorefun in `sort_at_path`).
23		# @examples #result <- sort_at_path(result, c('root', 'AEBODSYS'), scorefun = jj_complex_scorefun())
24		#' @examples
25		#' ADAE <- data.frame(
26		#' USUBJID = c(
27		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
28		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
29		#' ),
30		#' AEBODSYS = c(
31		#' 'SOC 1', 'SOC 2', 'SOC 1', 'SOC 2', 'SOC 2',
32		#' 'SOC 2', 'SOC 2', 'SOC 1', 'SOC 2', 'SOC 1'
33		#' ),
34		#' AEDECOD = c(
35		#' 'Coded Term 2', 'Coded Term 1', 'Coded Term 3', 'Coded Term 4',
36		#' 'Coded Term 4', 'Coded Term 4', 'Coded Term 5', 'Coded Term 3',
37		#' 'Coded Term 1', 'Coded Term 2'
38		#' ),
39		#' TRT01A = c(
40		#' 'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
41		#' 'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
42		#' ),
43		#' TRTEMFL = c('Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y')
44		#' )
45		#'
46		#' ADAE <- ADAE \|>
47		#' dplyr::mutate(TRT01A = as.factor(TRT01A))
48		#'
49		#' ADAE$colspan_trt <- factor(ifelse(ADAE$TRT01A == 'Placebo', ' ', 'Active Study Agent'),
50		#' levels = c('Active Study Agent', ' ')
51		#' )
52		#'
53		#' ADAE$rrisk_header <- 'Risk Difference (%) (95% CI)'
54		#' ADAE$rrisk_label <- paste(ADAE$TRT01A, paste('vs', 'Placebo'))
55		#'
56		#' colspan_trt_map <- create_colspan_map(ADAE,
57		#' non_active_grp = 'Placebo',
58		#' non_active_grp_span_lbl = ' ',
59		#' active_grp_span_lbl = 'Active Study Agent',
60		#' colspan_var = 'colspan_trt',
61		#' trt_var = 'TRT01A'
62		#' )
63		#'
64		#' ref_path <- c("colspan_trt", " ", "TRT01A", "Placebo")
65		#'
66		#' lyt <- basic_table() \|>
67		#' split_cols_by(
68		#' 'colspan_trt',
69		#' split_fun = trim_levels_to_map(map = colspan_trt_map)
70		#' ) \|>
71		#' split_cols_by('TRT01A') \|>
72		#' split_cols_by('rrisk_header', nested = FALSE) \|>
73		#' split_cols_by(
74		#' 'TRT01A',
75		#' labels_var = 'rrisk_label',
76		#' split_fun = remove_split_levels('Placebo')
77		#' ) \|>
78		#' analyze(
79		#' 'TRTEMFL',
80		#' a_freq_j,
81		#' show_labels = 'hidden',
82		#' extra_args = list(
83		#' method = 'wald',
84		#' label = 'Subjects with >=1 AE',
85		#' ref_path = ref_path,
86		#' .stats = "count_unique_fraction"
87		#' )
88		#' ) \|>
89		#' split_rows_by('AEBODSYS',
90		#' split_label = 'System Organ Class',
91		#' split_fun = trim_levels_in_group('AEDECOD'),
92		#' label_pos = 'topleft',
93		#' section_div = c(' '),
94		#' nested = FALSE
95		#' ) \|>
96		#' summarize_row_groups(
97		#' 'AEBODSYS',
98		#' cfun = a_freq_j,
99		#' extra_args = list(
100		#' method = 'wald',
101		#' ref_path = ref_path,
102		#' .stats = "count_unique_fraction"
103		#' )
104		#' ) \|>
105		#' analyze(
106		#' 'AEDECOD',
107		#' afun = a_freq_j,
108		#' extra_args = list(
109		#' method = 'wald',
110		#' ref_path = ref_path,
111		#' .stats = "count_unique_fraction"
112		#' )
113		#' )
114		#'
115		#' result <- build_table(lyt, ADAE)
116		#'
117		#' result
118		#'
119		#' # now add sorting function to sort by AEBODSYS and AEDECOD within SOC
120		#' # using complex score function which sorts
121		#' # using the last active treatment column by default
122		#' result <- sort_at_path(
123		#' result,
124		#' c('root', 'AEBODSYS'),
125		#' scorefun = jj_complex_scorefun()
126		#' )
127		#'
128		#' result <- sort_at_path(
129		#' result,
130		#' c('root', 'AEBODSYS', '*', 'AEDECOD'),
131		#' scorefun = jj_complex_scorefun()
132		#' )
133		#'
134		#' result
135		#' @rdname complex_scoring_function
136		#' @aliases jj_complex_scorefun
137		jj_complex_scorefun <- function(
138		spanningheadercolvar = "colspan_trt",
139		usefirstcol = FALSE,
140		colpath = NULL,
141		firstcat = NULL,
142		lastcat = NULL
143		) {
144	12x	paths <- NULL
145
146	12x	function(tt) {
147	225x	if (is.null(paths)) {
148	12x	paths <<- col_paths(tt)
149	12x	if (is.null(colpath)) {
150	10x	if (is.na(spanningheadercolvar)) {
151	6x	atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
152	6x	use_paths <- atrt_paths
153	6x	act_trt_lst <- paths[use_paths]
154	6x	first_list <- sapply(act_trt_lst, utils::head, 1)
155	6x	first_at_value <- utils::head(first_list, n = 1)
156	6x	colpath <<- first_at_value
157		} else {
158	4x	atrt_paths <- vapply(paths, function(pth) pth[[1]] == spanningheadercolvar && pth[[2]] != " ", TRUE)
159	4x	use_paths <- atrt_paths
160	4x	act_trt_lst <- paths[use_paths]
161	4x	last_list <- sapply(act_trt_lst, utils::tail, 1)
162	4x	last_at_value <- utils::tail(last_list, n = 1)
163	4x	colpath <<- last_at_value
164		}
165
166	10x	if (usefirstcol) {
167	4x	atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
168	4x	use_paths <- atrt_paths
169	4x	act_trt_lst <- paths[use_paths]
170	4x	first_list <- sapply(act_trt_lst, utils::head, 1)
171	4x	first_at_value <- utils::head(first_list, n = 1)
172	4x	colpath <<- first_at_value
173		}
174		}
175		}
176	225x	score <- unlist(cell_values(tt, colpath = colpath), use.names = FALSE)[1]
177
178	225x	if (length(score) == 0) {
179	!	score <- 1
180		}
181
182	225x	if (!is.null(firstcat)) {
183	30x	if (obj_name(tt) == firstcat) {
184	3x	score <- Inf
185		}
186		}
187	225x	if (!is.null(lastcat)) {
188	30x	if (obj_name(tt) == lastcat) {
189	3x	score <- -99999
190		}
191		}
192	225x	if (obj_name(tt) == " ") {
193	!	score <- -Inf
194		}
195
196	225x	return(score)
197		}
198		}

1		#' @name a_freq_combos_j
2		#'
3		#' @title Analysis function count and percentage in column design controlled by combosdf
4		#'
5		#' @inheritParams proposal_argument_convention
6		#' @inheritParams a_freq_j
7		#'
8		#' @param combosdf The df which provides the mapping of facets to produce cumulative counts for .N_col.
9		#' @note: These extra records must then be removed from the numerator via the filter_var parameter
10		#' to avoid double counting of events.
11		#' @param do_not_filter A vector of facets (i.e., column headers), identifying headers for which
12		#' no filtering of records should occur.
13		#' That is, the numerator should contain cumulative counts. Generally, this will be used for a
14		#' "Total" column, or something similar.
15		#' @param filter_var The variable which identifies the records to count in the numerator for any given column.
16		#' Generally, this will contain text matching the column header for the column associated with a given record.
17		#' @param flag_var Variable which identifies the occurrence (or first occurrence) of an event.
18		#' The flag variable is expected to have a value of "Y" identifying that the event should be counted, or NA otherwise.
19
20		#' @param denom (`string`)\cr
21		#' One of \cr
22		#' \itemize{
23		#' \item \strong{N_col} Column count, \cr
24		#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
25		#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
26		#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
27		#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
28		#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
29		#' (`.row_df` from the rtables splitting machinery).\cr
30		#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
31		#' This higher row-level split is specified in the argument `denom_by`.\cr
32		#' }
33		#' @param .formats (named 'character' or 'list')\cr
34		#' formats for the statistics.
35		#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
36		#' @export
37
38		a_freq_combos_j <- function(
39		df,
40		labelstr = NULL,
41		.var = NA,
42		val = NULL,
43		# arguments specific to a_freq_combos_j
44		combosdf = NULL,
45		do_not_filter = NULL,
46		filter_var = NULL,
47		flag_var = NULL,
48		# arguments specific to a_freq_combos_j till here
49		.df_row,
50		.spl_context,
51		.N_col,
52		id = "USUBJID",
53		denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
54		label = NULL,
55		label_fstr = NULL,
56		label_map = NULL,
57		.alt_df_full = NULL,
58		denom_by = NULL,
59		.stats = "count_unique_denom_fraction",
60		.formats = NULL,
61		.labels_n = NULL,
62		.indent_mods = NULL,
63		na_str = rep("NA", 3)
64		) {
65	12x	denom <- match.arg(denom)
66
67	12x	if (denom %in% c("n_altdf") && is.null(.alt_df_full)) {
68	!	stop(".alt_df_full cannot be NULL when denom = n_altdf.")
69		}
70
71	12x	if (!is.null(combosdf) && !all(c("valname", "label") %in% names(combosdf))) {
72	!	stop("a_freq_combos_j: combosdf must have variables valname and label.")
73		}
74
75	12x	res_dataprep <- h_a_freq_dataprep(
76	12x	df = df,
77	12x	labelstr = labelstr,
78	12x	.var = .var,
79	12x	val = val,
80	12x	drop_levels = FALSE,
81	12x	excl_levels = NULL,
82	12x	new_levels = NULL,
83	12x	new_levels_after = FALSE,
84	12x	.df_row = .df_row,
85	12x	.spl_context = .spl_context,
86	12x	.N_col = .N_col,
87	12x	id = id,
88	12x	denom = denom,
89	12x	variables = NULL,
90	12x	label = label,
91	12x	label_fstr = label_fstr,
92	12x	label_map = label_map,
93	12x	.alt_df_full = .alt_df_full,
94	12x	denom_by = denom_by,
95	12x	.stats = .stats
96		)
97		# res_dataprep is list with elements
98		# df .df_row val
99		# drop_levels excl_levels
100		# alt_df parentdf new_denomdf
101		# .stats
102		# make these elements available in current environment
103	12x	df <- res_dataprep$df
104	12x	.df_row <- res_dataprep$.df_row
105	12x	val <- res_dataprep$val
106	12x	drop_levels <- res_dataprep$drop_levels
107	12x	excl_levels <- res_dataprep$excl_levels
108	12x	alt_df <- res_dataprep$alt_df
109	12x	parentdf <- res_dataprep$parentdf
110	12x	new_denomdf <- res_dataprep$new_denomdf
111	12x	.stats <- .stats
112
113		## colid can be used to figure out if we're in the combo column or not
114	12x	colid <- .spl_context$cur_col_id[[1]]
115
116		### this is the core code for subsetting to appropriate combo level
117	12x	df <- h_subset_combo(
118	12x	df = df,
119	12x	combosdf = combosdf,
120	12x	do_not_filter = do_not_filter,
121	12x	filter_var = filter_var,
122	12x	flag_var = flag_var,
123	12x	colid = colid
124		)
125
126		## the same s-function can be used as in a_freq_j
127	12x	x_stats <- s_freq_j(
128	12x	df,
129	12x	.var = .var,
130	12x	.df_row = .df_row,
131	12x	val = val,
132	12x	alt_df = new_denomdf,
133	12x	parent_df = new_denomdf,
134	12x	id = id,
135	12x	denom = denom,
136	12x	.N_col = .N_col,
137	12x	countsource = "df"
138		)
139
140	12x	.stats_adj <- .stats
141
142	12x	res_prepinrows <- h_a_freq_prepinrows(
143	12x	x_stats,
144	12x	.stats_adj,
145	12x	.formats,
146	12x	labelstr,
147	12x	label_fstr,
148	12x	label,
149	12x	.indent_mods,
150	12x	.labels_n,
151	12x	na_str
152		)
153		# res_prepinrows is list with elements
154		# x_stats .formats .labels .indent_mods .format_na_strs
155		# make these elements available in current environment
156	12x	x_stats <- res_prepinrows$x_stats
157	12x	.formats <- res_prepinrows$.formats
158	12x	.labels <- res_prepinrows$.labels
159	12x	.indent_mods <- res_prepinrows$.indent_mods
160	12x	.format_na_strs <- res_prepinrows$.format_na_strs
161
162		### final step: turn requested stats into rtables rows
163	12x	in_rows(
164	12x	.list = x_stats,
165	12x	.formats = .formats,
166	12x	.labels = .labels,
167	12x	.indent_mods = .indent_mods,
168	12x	.format_na_strs = .format_na_strs
169		)
170		}

1		#' Adding Labels To Variables For Model
2		#'
3		#' @param vars (`list`)\cr variables to use.
4		#' @param data (`data.frame`)\cr data to use.
5		#' @param x (`character`)\cr an element in vars.
6		#'
7		#' @name labels
8		#' @keywords internal
9		NULL
10
11		#' @describeIn labels checks if element in `vars` is not `NULL` and not empty.
12		h_is_specified <- function(x, vars) {
13	112x	!is.null(vars[[x]]) && (length(vars[[x]]) > 0)
14		}
15
16		#' @describeIn labels checks if element in vars is not NULL and exists in dataset.
17		h_is_specified_and_in_data <- function(x, vars, data) {
18	70x	h_is_specified(x, vars) && all(vars[[x]] %in% names(data))
19		}
20
21		#' @describeIn labels gets label for each element in vars.
22		h_check_and_get_label <- function(x, vars, data) {
23	70x	checkmate::assert_true(h_is_specified_and_in_data(x, vars, data))
24	70x	res <- NULL
25	70x	for (v in vars[[x]]) {
26	84x	label <- attr(data[[v]], "label")
27	84x	string <- ifelse(!is.null(label), label, v)
28	84x	res <- c(res, stats::setNames(string, v))
29		}
30	70x	res
31		}
32
33		#' Extraction of Covariate Parts from Character Vector
34		#'
35		#' @param covariates (`character`)\cr specification in the usual way, see examples.
36		#'
37		#' @return Character vector of the covariates involved in `covariates` specification.
38		#' @keywords internal
39		h_get_covariate_parts <- function(covariates) {
40	14x	checkmate::assert_character(covariates, null.ok = TRUE)
41	14x	if (is.null(covariates)) {
42	!	NULL
43		} else {
44	14x	unique(unlist(strsplit(covariates, split = "\\*\|:")))
45		}
46		}
47
48		#' @describeIn labels returns the list of variables with labels.
49		h_labels <- function(vars, data) {
50	14x	checkmate::assert_list(vars)
51	14x	checkmate::assert_data_frame(data)
52	14x	labels <- list()
53	14x	labels$response <- h_check_and_get_label("response", vars, data)
54	14x	labels$id <- h_check_and_get_label("id", vars, data)
55	14x	labels$visit <- h_check_and_get_label("visit", vars, data)
56	14x	if (h_is_specified("arm", vars)) {
57	14x	labels$arm <- h_check_and_get_label("arm", vars, data)
58		}
59	14x	if (h_is_specified("covariates", vars)) {
60	14x	vars$parts <- h_get_covariate_parts(vars$covariates)
61	14x	labels$parts <- h_check_and_get_label("parts", vars, data)
62		}
63	14x	if (h_is_specified("weights", vars)) {
64	!	labels$weights <- h_check_and_get_label("weights", vars, data)
65		}
66	14x	return(labels)
67		}
68
69		#' Building Model Formula
70		#'
71		#' This builds the model formula which is used inside [fit_mmrm_j()] and provided
72		#' to [mmrm::mmrm()] internally. It can be instructive to look at the resulting
73		#' formula directly sometimes.
74		#'
75		#' @param vars (`list`)\cr variables to use in the model.
76		#' @param cor_struct (`string`)\cr specify the covariance structure to use.
77		#' @return Formula to use in [mmrm::mmrm()].
78		#' @export
79		#'
80		#' @examples
81		#' vars <- list(
82		#' response = 'AVAL', covariates = c('RACE', 'SEX'),
83		#' id = 'USUBJID', arm = 'ARMCD', visit = 'AVISIT'
84		#' )
85		#' build_formula(vars, 'auto-regressive')
86		#' build_formula(vars)
87		build_formula <- function(
88		vars,
89		cor_struct = c(
90		"unstructured",
91		"toeplitz",
92		"heterogeneous toeplitz",
93		"ante-dependence",
94		"heterogeneous ante-dependence",
95		"auto-regressive",
96		"heterogeneous auto-regressive",
97		"compound symmetry",
98		"heterogeneous compound symmetry"
99		)
100		) {
101	9x	checkmate::assert_list(vars)
102	9x	cor_struct <- match.arg(cor_struct)
103	9x	covariates_part <- paste(vars$covariates, collapse = " + ")
104	9x	arm_visit_part <- if (is.null(vars$arm)) {
105	!	vars$visit
106		} else {
107	9x	paste0(vars$arm, "*", vars$visit)
108		}
109	9x	random_effects_fun <- switch(
110	9x	cor_struct,
111	9x	unstructured = "us",
112	9x	toeplitz = "toep",
113	9x	`heterogeneous toeplitz` = "toeph",
114	9x	`ante-dependence` = "ad",
115	9x	`heterogeneous ante-dependence` = "adh",
116	9x	`auto-regressive` = "ar1",
117	9x	`heterogeneous auto-regressive` = "ar1h",
118	9x	`compound symmetry` = "cs",
119	9x	`heterogeneous compound symmetry` = "csh"
120		)
121	9x	random_effects_part <- paste0(random_effects_fun, "(", vars$visit, " \| ", vars$id, ")")
122	9x	rhs_formula <- paste(arm_visit_part, "+", random_effects_part)
123	9x	if (covariates_part != "") {
124	9x	rhs_formula <- paste(covariates_part, "+", rhs_formula)
125		}
126	9x	stats::as.formula(paste(vars$response, "~", rhs_formula))
127		}
128
129		#' Extract Least Square Means from `MMRM`
130		#'
131		#' Extracts the least square means from an `MMRM` fit.
132		#'
133		#' @param fit (`mmrm`)\cr result of [mmrm::mmrm()].
134		#' @inheritParams fit_mmrm_j
135		#' @param averages (`list`)\cr named list of visit levels which should be averaged
136		#' and reported along side the single visits.
137		#' @param weights (`string`)\cr type of weights to be used for the least square means,
138		#' see [emmeans::emmeans()] for details.
139		#' @return A list with data frames `estimates` and `contrasts`.
140		#' The attributes `averages` and `weights` save the settings used.
141		#'
142		#' @export
143		get_mmrm_lsmeans <- function(fit, vars, conf_level, weights, averages = list()) {
144	10x	checkmate::assert_class(fit, "mmrm")
145	10x	checkmate::assert_list(averages, types = "character")
146	10x	emmeans_res <- h_get_emmeans_res(fit, vars, weights)
147
148		# Get least square means estimates for single visits, and possibly averaged visits.
149	10x	estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
150	10x	if (length(averages)) {
151	4x	average_specs <- h_get_average_visit_specs(emmeans_res, vars, averages, fit)
152	4x	average_estimates <- h_get_spec_visit_estimates(emmeans_res, average_specs, conf_level)
153	4x	estimates <- rbind(estimates, average_estimates)
154		}
155	10x	has_arm_var <- !is.null(vars$arm)
156	10x	if (!has_arm_var) {
157	!	return(list(estimates = estimates))
158		}
159		# Continue with contrasts when we have an arm variable.
160	10x	contrast_specs <- h_single_visit_contrast_specs(emmeans_res, vars)
161	10x	contrast_estimates <- h_get_spec_visit_estimates(emmeans_res, contrast_specs, conf_level, tests = TRUE)
162	10x	if (length(averages)) {
163	4x	average_contrast_specs <- h_average_visit_contrast_specs(contrast_specs, averages)
164	4x	average_contrasts <- h_get_spec_visit_estimates(emmeans_res, average_contrast_specs, conf_level, tests = TRUE)
165	4x	contrast_estimates <- rbind(contrast_estimates, average_contrasts)
166		}
167
168	10x	relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
169	10x	contrast_estimates <- merge(contrast_estimates, relative_reduc_df, by = c(vars$arm, vars$visit), sort = FALSE)
170	10x	contrast_estimates[[vars$arm]] <- factor(contrast_estimates[[vars$arm]])
171	10x	contrast_estimates[[vars$visit]] <- factor(contrast_estimates[[vars$visit]])
172	10x	structure(list(estimates = estimates, contrasts = contrast_estimates), averages = averages, weights = weights)
173		}
174
175		#' `MMRM` Analysis
176		#'
177		#' Does the `MMRM` analysis. Multiple other functions can be called on the result to produce
178		#' tables and graphs.
179		#'
180		#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `MMRM`.
181		#' The following elements need to be included as character vectors and match corresponding columns
182		#' in `data`:
183		#'
184		#' - `response`: the response variable.
185		#' - `covariates`: the additional covariate terms (might also include interactions).
186		#' - `id`: the subject ID variable.
187		#' - `arm`: the treatment group variable (factor).
188		#' - `visit`: the visit variable (factor).
189		#' - `weights`: optional weights variable (if `NULL` or omitted then no weights will be used).
190		#'
191		#' Note that the main effects and interaction of `arm` and `visit` are by default
192		#' included in the model.
193		#' @param data (`data.frame`)\cr with all the variables specified in
194		#' `vars`. Records with missing values in any independent variables
195		#' will be excluded.
196		#' @param conf_level (`proportion`)\cr confidence level of the interval.
197		#' @param cor_struct (`string`)\cr specifying the covariance structure, defaults to
198		#' `'unstructured'`. See the details.
199		#' @param averages_emmeans (`list`)\cr optional named list of visit levels which should be averaged
200		#' and reported along side the single visits.
201		#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
202		#' @param ... additional arguments for [mmrm::mmrm()], in particular `reml` and options listed in
203		#' [mmrm::mmrm_control()].
204		#'
205		#' @details Multiple different degree of freedom adjustments are available via the `method` argument
206		#' for [mmrm::mmrm()]. In addition, covariance matrix adjustments are available via `vcov`.
207		#' Please see [mmrm::mmrm_control()] for details and additional useful options.
208		#'
209		#' For the covariance structure (`cor_struct`), the user can choose among the following options.
210		#'
211		#' - `unstructured`: Unstructured covariance matrix. This is the most flexible choice and default.
212		#' If there are `T` visits, then `T * (T+1) / 2` variance parameters are used.
213		#' - `toeplitz`: Homogeneous Toeplitz covariance matrix, which uses `T` variance parameters.
214		#' - `heterogeneous toeplitz`: Heterogeneous Toeplitz covariance matrix,
215		#' which uses `2 * T - 1` variance parameters.
216		#' - `ante-dependence`: Homogeneous Ante-Dependence covariance matrix, which uses `T` variance parameters.
217		#' - `heterogeneous ante-dependence`: Heterogeneous Ante-Dependence covariance matrix,
218		#' which uses `2 * T - 1` variance parameters.
219		#' - `auto-regressive`: Homogeneous Auto-Regressive (order 1) covariance matrix,
220		#' which uses 2 variance parameters.
221		#' - `heterogeneous auto-regressive`: Heterogeneous Auto-Regressive (order 1) covariance matrix,
222		#' which uses `T + 1` variance parameters.
223		#' - `compound symmetry`: Homogeneous Compound Symmetry covariance matrix, which uses 2
224		#' variance parameters.
225		#' - `heterogeneous compound symmetry`: Heterogeneous Compound Symmetry covariance matrix, which uses
226		#' `T + 1` variance parameters.
227		#'
228		#' @return A `tern_model` object which is a list with model results:
229		#'
230		#' - `fit`: The `mmrm` object which was fitted to the data. Note that via `mmrm::component(fit, 'optimizer')`
231		#' the finally used optimization algorithm can be obtained, which can be useful for refitting the model
232		#' later on.
233		#' - `cov_estimate`: The matrix with the covariance matrix estimate.
234		#' - `diagnostics`: A list with model diagnostic statistics (REML criterion, AIC, corrected AIC, BIC).
235		#' - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
236		#' The attributes `averages` and `weights` save the settings used
237		#' (`averages_emmeans` and `weights_emmeans`).
238		#' - `vars`: The variable list.
239		#' - `labels`: Corresponding list with variable labels extracted from `data`.
240		#' - `cor_struct`: input.
241		#' - `ref_level`: The reference level for the arm variable, which is always the first level.
242		#' - `treatment_levels`: The treatment levels for the arm variable.
243		#' - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
244		#' - `additional`: List with any additional inputs passed via `...`
245		#'
246		#' @export
247		#'
248		#' @note This function has the `_j` suffix to distinguish it from [mmrm::fit_mmrm()].
249		#' It is a copy from the `tern.mmrm` package and later will be replaced by [tern.mmrm::fit_mmrm()].
250		#' No new features are included in this function here.
251		#'
252		#' @examples
253		#' mmrm_results <- fit_mmrm_j(
254		#' vars = list(
255		#' response = 'FEV1',
256		#' covariates = c('RACE', 'SEX'),
257		#' id = 'USUBJID',
258		#' arm = 'ARMCD',
259		#' visit = 'AVISIT'
260		#' ),
261		#' data = mmrm::fev_data,
262		#' cor_struct = 'unstructured',
263		#' weights_emmeans = 'equal',
264		#' averages_emmeans = list(
265		#' 'VIS1+2' = c('VIS1', 'VIS2')
266		#' )
267		#' )
268		fit_mmrm_j <- function(
269		vars = list(response = "AVAL", covariates = c(), id = "USUBJID", arm = "ARM", visit = "AVISIT"),
270		data,
271		conf_level = 0.95,
272		cor_struct = "unstructured",
273		weights_emmeans = "counterfactual",
274		averages_emmeans = list(),
275		...
276		) {
277	9x	labels <- h_labels(vars, data)
278	9x	formula <- build_formula(vars, cor_struct)
279	9x	weights <- if (!is.null(vars$weights)) data[[vars$weights]] else NULL
280
281	9x	fit <- mmrm::mmrm(formula = formula, data = data, weights = weights, reml = TRUE, ...)
282	9x	lsmeans <- get_mmrm_lsmeans(
283	9x	fit = fit,
284	9x	vars = vars,
285	9x	conf_level = conf_level,
286	9x	averages = averages_emmeans,
287	9x	weights = weights_emmeans
288		)
289	9x	cov_estimate <- mmrm::VarCorr(fit)
290	9x	visit_levels <- rownames(cov_estimate)
291	9x	contrasts_from_visits <- match(visit_levels, lsmeans$contrasts[[vars$visit]])
292	9x	df <- stats::setNames(lsmeans$contrasts$df[contrasts_from_visits], visit_levels)
293	9x	results <- list(
294	9x	fit = fit,
295	9x	cov_estimate = cov_estimate,
296	9x	lsmeans = lsmeans,
297	9x	vars = vars,
298	9x	labels = labels,
299	9x	mse = diag(cov_estimate),
300	9x	df = df,
301	9x	cor_struct = cor_struct,
302	9x	ref_level = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[1],
303	9x	treatment_levels = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[-1],
304	9x	conf_level = conf_level,
305	9x	additional = list(...)
306		)
307	9x	class(results) <- "tern_model"
308	9x	return(results)
309		}

1		#' Tabulation of Least Square Means Results
2		#'
3		#' @description `r lifecycle::badge('stable')`
4		#'
5		#' These functions can be used to produce tables from LS means, e.g. from [fit_mmrm_j()]
6		#' or [fit_ancova()].
7		#'
8		#' @note These functions have been forked from the `tern.mmrm` package. Additional features
9		#' are:
10		#'
11		#' * Additional `ref_path` argument for [summarize_lsmeans()]
12		#' * The function is more general in that it also works for LS means results from ANCOVA
13		#' * Additional statistic `diff_mean_est_ci` is returned
14		#' * P-value sidedness can be chosen
15		#'
16		#' @name tabulate_lsmeans
17		#' @examples
18		#' result <- fit_mmrm_j(
19		#' vars = list(
20		#' response = 'FEV1',
21		#' covariates = c('RACE', 'SEX'),
22		#' id = 'USUBJID',
23		#' arm = 'ARMCD',
24		#' visit = 'AVISIT'
25		#' ),
26		#' data = mmrm::fev_data,
27		#' cor_struct = 'unstructured',
28		#' weights_emmeans = 'equal'
29		#' )
30		#'
31		#' df <- broom::tidy(result)
32		#'
33		#' s_lsmeans(df[8, ], .in_ref_col = FALSE)
34		#' s_lsmeans(df[8, ], .in_ref_col = FALSE, alternative = "greater", show_relative = "increase")
35		#'
36		#' dat_adsl <- mmrm::fev_data \|>
37		#' dplyr::select(USUBJID, ARMCD) \|>
38		#' unique()
39		#'
40		#' basic_table() \|>
41		#' split_cols_by("ARMCD") \|>
42		#' add_colcounts() \|>
43		#' split_rows_by("AVISIT") \|>
44		#' analyze(
45		#' "AVISIT",
46		#' afun = a_lsmeans,
47		#' show_labels = "hidden",
48		#' na_str = tern::default_na_str(),
49		#' extra_args = list(
50		#' .stats = c(
51		#' "n",
52		#' "adj_mean_se",
53		#' "adj_mean_ci",
54		#' "diff_mean_se",
55		#' "diff_mean_ci"
56		#' ),
57		#' .labels = c(
58		#' adj_mean_se = "Adj. LS Mean (Std. Error)",
59		#' adj_mean_ci = "95% CI",
60		#' diff_mean_ci = "95% CI"
61		#' ),
62		#' .formats = c(adj_mean_se = jjcsformat_xx("xx.x (xx.xx)")),
63		#' alternative = "greater",
64		#' ref_path = c("ARMCD", result$ref_level)
65		#' )
66		#' ) \|>
67		#' build_table(
68		#' df = broom::tidy(result),
69		#' alt_counts_df = dat_adsl
70		#' )
71		NULL
72
73		#' @describeIn tabulate_lsmeans Helper method (for [broom::tidy()]) to prepare a `data.frame` from an
74		#' `tern_model` object containing the least-squares means and contrasts.
75		#' @method tidy tern_model
76		#' @importFrom generics tidy
77		#' @export
78		tidy.tern_model <- function(x, ...) {
79		# nolint
80	57x	vars <- x$vars
81	57x	estimates <- x$lsmeans$estimates
82	57x	df <- if (is.null(vars$arm)) {
83	!	nams <- names(estimates)
84	!	to_rename <- match(c("estimate", "se", "df", "lower_cl", "upper_cl"), nams)
85	!	names(estimates)[to_rename] <- paste0(names(estimates)[to_rename], "_est")
86	!	estimates
87		} else {
88	57x	contrasts <- x$lsmeans$contrasts
89	57x	merge(x = estimates, y = contrasts, by = c(vars$visit, vars$arm), suffixes = c("_est", "_contr"), all = TRUE)
90		}
91	57x	df[[vars$arm]] <- factor(df[[vars$arm]], levels = levels(estimates[[vars$arm]]))
92	57x	df[[vars$visit]] <- factor(df[[vars$visit]], levels = levels(estimates[[vars$visit]]))
93	57x	df$conf_level <- x$conf_level
94	57x	if (!is.null(x$mse)) {
95	57x	df$mse <- x$mse[df[[vars$visit]]]
96		}
97	57x	if (!is.null(x$df)) {
98	57x	df$df <- x$df[df[[vars$visit]]]
99		}
100	57x	df
101		}
102
103		#' @describeIn tabulate_lsmeans Statistics function which is extracting estimates from a tidied least-squares means
104		#' data frame.
105		#' @inheritParams proposal_argument_convention
106		#' @export
107		s_lsmeans <- function(df,
108		.in_ref_col,
109		alternative = c("two.sided", "less", "greater"),
110		show_relative = c("reduction", "increase")) {
111	85x	alternative <- match.arg(alternative)
112	85x	show_relative <- match.arg(show_relative)
113	85x	if_not_ref <- function(x) if (.in_ref_col) character() else x
114	85x	list(
115	85x	n = df$n,
116	85x	adj_mean_se = c(df$estimate_est, df$se_est),
117	85x	adj_mean_ci = with_label(
118	85x	c(df$lower_cl_est, df$upper_cl_est),
119	85x	paste0("Adjusted Mean ", f_conf_level(df$conf_level))
120		),
121	85x	adj_mean_est_ci = with_label(
122	85x	c(df$estimate_est, df$lower_cl_est, df$upper_cl_est),
123	85x	paste0("Adjusted Mean (", f_conf_level(df$conf_level), ")")
124		),
125	85x	diff_mean_se = if_not_ref(c(df$estimate_contr, df$se_contr)),
126	85x	diff_mean_ci = with_label(
127	85x	if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
128	85x	paste0("Difference in Adjusted Means ", f_conf_level(df$conf_level))
129		),
130	85x	diff_mean_est_ci = with_label(
131	85x	if_not_ref(c(df$estimate_contr, df$lower_cl_contr, df$upper_cl_contr)),
132	85x	paste0("Difference in Adjusted Means (", f_conf_level(df$conf_level), ")")
133		),
134	85x	change = switch(
135	85x	show_relative,
136	85x	reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
137	85x	increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
138		),
139	85x	p_value = if_not_ref(switch(
140	85x	alternative,
141	85x	two.sided = with_label(df$p_value, "2-sided p-value"),
142	85x	less = with_label(df$p_value_less, "1-sided p-value (less)"),
143	85x	greater = with_label(df$p_value_greater, "1-sided p-value (greater)")
144		))
145		)
146		}
147
148		#' @describeIn tabulate_lsmeans Formatted Analysis function to be used as `afun`
149		#' @export
150		a_lsmeans <- function(df,
151		ref_path,
152		.spl_context,
153		...,
154		.stats = NULL,
155		.formats = NULL,
156		.labels = NULL,
157		.indent_mods = NULL) {
158		# Check for additional parameters to the statistics function
159	30x	dots_extra_args <- list(...)
160
161		# Only support default stats, not custom stats
162	30x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
163
164		# Obtain reference column information
165	30x	ref <- get_ref_info(ref_path, .spl_context)
166
167		# Apply statistics function
168	30x	x_stats <- .apply_stat_functions(
169	30x	default_stat_fnc = s_lsmeans,
170	30x	custom_stat_fnc_list = NULL,
171	30x	args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
172		)
173
174		# Format according to specifications
175	30x	format_stats(
176	30x	x_stats,
177	30x	method_groups = "tabulate_lsmeans",
178	30x	stats_in = .stats,
179	30x	formats_in = .formats,
180	30x	labels_in = .labels,
181	30x	indents_in = .indent_mods
182		)
183		}

1		#' @note: This has been forked from the `rbmi` package, mainly to support in addition
2		#' the pooling of variance estimates.
3		rbmi_pool <- function(
4		results,
5		conf.level = 0.95,
6		alternative = c("two.sided", "less", "greater"),
7		type = c("percentile", "normal")
8		) {
9	!	rbmi::validate(results)
10
11	!	alternative <- match.arg(alternative)
12	!	type <- match.arg(type)
13
14	!	pool_type <- class(results$results)[[1]]
15	!	checkmate::assert_true(identical(pool_type, "rubin"))
16
17	!	results_transpose <- (utils::getFromNamespace("transpose_results", "rbmi"))(
18	!	results$results,
19	!	(utils::getFromNamespace("get_pool_components", "rbmi"))(pool_type)
20		)
21
22	!	pars <- lapply(
23	!	results_transpose,
24	!	function(x, ...) mod_pool_internal_rubin(x, ...),
25	!	conf.level = conf.level,
26	!	alternative = alternative,
27	!	type = type,
28	!	D = results$method$D
29		)
30
31	!	method <- pool_type
32
33	!	ret <- list(
34	!	pars = pars,
35	!	conf.level = conf.level,
36	!	alternative = alternative,
37	!	N = length(results$results),
38	!	method = method
39		)
40	!	class(ret) <- "pool"
41	!	return(ret)
42		}
43
44		mod_pool_internal_rubin <- function(results, conf.level, alternative, type, D) {
45	3x	ests <- results$est
46	3x	ses <- results$se
47	3x	dfs <- results$df
48	3x	alpha <- 1 - conf.level
49
50		# Note: Need to take median here, because in the MMRM case the d.f. will be slightly different for each imputed
51		# data set analysis.
52	3x	v_com <- stats::median(dfs)
53
54	3x	res_rubin <- (utils::getFromNamespace("rubin_rules", "rbmi"))(ests = ests, ses = ses, v_com = v_com)
55
56	3x	ret <- (utils::getFromNamespace("parametric_ci", "rbmi"))(
57	3x	point = res_rubin$est_point,
58	3x	se = sqrt(res_rubin$var_t),
59	3x	alpha = alpha,
60	3x	alternative = alternative,
61	3x	qfun = stats::qt,
62	3x	pfun = stats::pt,
63	3x	df = res_rubin$df
64		)
65		# Here also return the pooled d.f.:
66	3x	ret$df <- res_rubin$df
67
68	3x	return(ret)
69		}

1		#' Workaround statistics function to add HR with CI
2		#'
3		#' This is a workaround for [tern::s_coxph_pairwise()], which adds a statistic
4		#' containing the hazard ratio estimate together with the confidence interval.
5		#'
6		#' @inheritParams proposal_argument_convention
7		#'
8		#'
9		#' @name coxph_hr
10		#' @order 1
11		NULL
12
13		#' @describeIn coxph_hr Statistics function forked from [tern::s_coxph_pairwise()].
14		#' the difference is that:
15		#' 1) It returns the additional statistic `lr_stat_df` (log rank statistic with degrees of freedom).
16		#' @export
17		#' @order 3
18		#'
19		#' @importFrom survival Surv coxph survdiff
20		#'
21		#' @examples
22		#' adtte_f <- tern::tern_ex_adtte \|>
23		#' dplyr::filter(PARAMCD == "OS") \|>
24		#' dplyr::mutate(is_event = CNSR == 0)
25		#' df <- adtte_f \|> dplyr::filter(ARMCD == 'ARM A')
26		#' df_ref <- adtte_f \|> dplyr::filter(ARMCD == 'ARM B')
27		#'
28		#' s_coxph_hr(
29		#' df = df,
30		#' .ref_group = df_ref,
31		#' .in_ref_col = FALSE,
32		#' .var = 'AVAL',
33		#' is_event = 'is_event',
34		#' strata = NULL
35		#' )
36		s_coxph_hr <- function(
37		df,
38		.ref_group,
39		.in_ref_col,
40		.var,
41		is_event,
42		strata = NULL,
43		control = control_coxph(),
44		alternative = c("two.sided", "less", "greater")
45		) {
46	9x	checkmate::assert_string(.var)
47	9x	checkmate::assert_numeric(df[[.var]])
48	9x	checkmate::assert_logical(df[[is_event]])
49	9x	assert_df_with_variables(df, list(tte = .var, is_event = is_event))
50	9x	alternative <- match.arg(alternative)
51	9x	pval_method <- control$pval_method
52	9x	ties <- control$ties
53	9x	conf_level <- control$conf_level
54
55	9x	if (.in_ref_col) {
56	2x	return(list(
57	2x	pvalue = with_label(list(), paste0("p-value (", pval_method, ")")),
58	2x	lr_stat_df = list(),
59	2x	hr = list(),
60	2x	hr_ci = with_label(list(), f_conf_level(conf_level)),
61	2x	hr_ci_3d = with_label(list(), paste0("Hazard Ratio (", f_conf_level(conf_level), ")")),
62	2x	n_tot = list(),
63	2x	n_tot_events = list()
64		))
65		}
66	7x	data <- rbind(.ref_group, df)
67	7x	group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
68
69	7x	df_cox <- data.frame(tte = data[[.var]], is_event = data[[is_event]], arm = group)
70	7x	if (is.null(strata)) {
71	3x	formula_cox <- survival::Surv(tte, is_event) ~ arm
72		} else {
73	4x	formula_cox <- stats::as.formula(paste0(
74	4x	"survival::Surv(tte, is_event) ~ arm + strata(",
75	4x	paste(strata, collapse = ","),
76		")"
77		))
78	4x	df_cox <- cbind(df_cox, data[strata])
79		}
80	7x	cox_fit <- survival::coxph(formula = formula_cox, data = df_cox, ties = ties)
81	7x	sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)
82	7x	original_survdiff <- survival::survdiff(formula_cox, data = df_cox)
83	7x	log_rank_stat <- original_survdiff$chisq
84
85		# See survival::survdiff for the d.f. calculation.
86	7x	etmp <- if (is.matrix(original_survdiff$exp)) {
87	4x	apply(original_survdiff$exp, 1, sum)
88		} else {
89	3x	original_survdiff$exp
90		}
91	7x	log_rank_df <- (sum(1 * (etmp > 0))) - 1
92		# Check the consistency of the d.f. with the p-value returned by survival::survdiff.
93	7x	log_rank_pvalue <- stats::pchisq(log_rank_stat, log_rank_df, lower.tail = FALSE)
94	7x	checkmate::assert_true(all.equal(log_rank_pvalue, original_survdiff$pvalue))
95
96	7x	pval <- switch(
97	7x	pval_method,
98	7x	wald = sum_cox$waldtest["pvalue"],
99	7x	`log-rank` = log_rank_pvalue,
100	7x	likelihood = sum_cox$logtest["pvalue"]
101		)
102
103		# Handle one-sided alternatives.
104	7x	if (alternative != "two.sided") {
105	2x	right_direction <- if (alternative == "less") {
106	1x	sum_cox$conf.int[1, 1] < 1
107		} else {
108	1x	sum_cox$conf.int[1, 1] >= 1
109		}
110	2x	pval <- if (right_direction) {
111	1x	pval / 2
112		} else {
113	1x	1 - pval / 2
114		}
115		}
116
117	7x	list(
118	7x	pvalue = with_label(unname(pval), paste0("p-value (", pval_method, ")")),
119	7x	lr_stat_df = unname(c(log_rank_stat, log_rank_df)),
120	7x	hr = sum_cox$conf.int[1, 1],
121	7x	hr_ci = with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),
122	7x	hr_ci_3d = with_label(
123	7x	c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])),
124	7x	paste0("Hazard Ratio (", f_conf_level(conf_level), ")")
125		),
126	7x	n_tot = sum_cox$n,
127	7x	n_tot_events = sum_cox$nevent
128		)
129		}
130
131		#' @describeIn coxph_hr Formatted analysis function which is used as `afun`.
132		#'
133		#' @examples
134		#' library(dplyr)
135		#'
136		#' adtte_f <- tern::tern_ex_adtte \|>
137		#' filter(PARAMCD == "OS") \|>
138		#' mutate(is_event = CNSR == 0)
139		#'
140		#' df <- adtte_f \|> filter(ARMCD == 'ARM A')
141		#' df_ref_group <- adtte_f \|> filter(ARMCD == 'ARM B')
142		#'
143		#' basic_table() \|>
144		#' split_cols_by(var = 'ARMCD', ref_group = 'ARM A') \|>
145		#' add_colcounts() \|>
146		#' analyze("AVAL",
147		#' afun = s_coxph_hr,
148		#' extra_args = list(is_event = 'is_event'),
149		#' var_labels = 'Unstratified Analysis',
150		#' show_labels = 'visible'
151		#' ) \|>
152		#' build_table(df = adtte_f)
153		#'
154		#' basic_table() \|>
155		#' split_cols_by(var = 'ARMCD', ref_group = 'ARM A') \|>
156		#' add_colcounts() \|>
157		#' analyze("AVAL",
158		#' afun = s_coxph_hr,
159		#' extra_args = list(is_event = 'is_event',
160		#' strata = 'SEX',
161		#' control = tern::control_coxph(pval_method = 'wald')),
162		#' var_labels = 'Unstratified Analysis',
163		#' show_labels = 'visible'
164		#' ) \|>
165		#' build_table(df = adtte_f)
166		#' @export
167		#' @order 2
168		a_coxph_hr <- function(
169		df,
170		.var,
171		ref_path,
172		.spl_context,
173		...,
174		.stats = NULL,
175		.formats = NULL,
176		.labels = NULL,
177		.indent_mods = NULL
178		) {
179		# Check for additional parameters to the statistics function
180	6x	dots_extra_args <- list(...)
181
182		# Only support default stats, not custom stats
183	6x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
184
185		# Obtain reference column information
186	6x	ref <- get_ref_info(ref_path, .spl_context)
187
188		# Apply statistics function
189	6x	x_stats <- .apply_stat_functions(
190	6x	default_stat_fnc = s_coxph_hr,
191	6x	custom_stat_fnc_list = NULL,
192	6x	args_list = c(
193	6x	df = list(df),
194	6x	.var = .var,
195	6x	.ref_group = list(ref$ref_group),
196	6x	.in_ref_col = ref$in_ref_col,
197	6x	dots_extra_args
198		)
199		)
200
201		# Format according to specifications
202	6x	format_stats(
203	6x	x_stats,
204	6x	method_groups = "coxph_hr",
205	6x	stats_in = .stats,
206	6x	formats_in = .formats,
207	6x	labels_in = .labels,
208	6x	indents_in = .indent_mods
209		)
210		}

1		#' Tabulation of RBMI Results
2		#'
3		#' @description `r lifecycle::badge('stable')`
4		#'
5		#' These functions can be used to produce tables from RBMI.
6		#'
7		#' @name tabulate_rbmi
8		#'
9		#' @note These functions have been forked from `tern.rbmi`. Additional features are:
10		#'
11		#' * Additional `ref_path` argument.
12		#' * Extraction of variance statistics in the `tidy()` method.
13		#' * Adapted to `rbmi` forked functions update with more than two treatment groups.
14		NULL
15
16		#' @describeIn tabulate_rbmi Helper function to produce data frame with results
17		#' of pool for a single visit.
18		#'
19		#' @param x (`list`)\cr is a list of pooled object from `rbmi` analysis results.
20		#' This list includes analysis results, confidence level, hypothesis testing type.
21		#' @param visit_name (`string`)\cr single visit level.
22		#' @param group_names (`character`)\cr group levels.
23		#' @return The `data.frame` with results of pooled analysis for a single visit.
24		#'
25		#' @export
26		h_tidy_pool <- function(x, visit_name, group_names) {
27	13x	checkmate::assert_list(x)
28	13x	checkmate::assert_string(visit_name)
29	13x	checkmate::assert_character(group_names)
30
31	13x	ref_name <- paste0("lsm_", group_names[1], "_", visit_name)
32	13x	ref <- x[[ref_name]]
33
34	13x	list2df <- \(l) with(l, data.frame(est, ci_l = ci[1], ci_u = ci[2], se, pvalue, df))
35
36	13x	var_name <- paste0("var_", visit_name)
37	13x	var <- if (var_name %in% names(x)) {
38		# This is the case for ANCOVA.
39	11x	list2df(x[[var_name]])
40		} else {
41		# This is the case for MMRM.
42	2x	var_names <- paste0("var_", group_names[-1], "_", visit_name)
43	2x	checkmate::assert_subset(var_names, names(x))
44	2x	var_dfs <- lapply(x[var_names], list2df)
45	2x	var <- do.call(rbind, var_dfs)
46		}
47
48	13x	contr_names <- paste0("trt_", group_names[-1], "_", visit_name)
49	13x	contr_dfs <- lapply(x[contr_names], list2df)
50	13x	contr <- do.call(rbind, contr_dfs)
51
52	13x	alt_names <- paste0("lsm_", group_names[-1], "_", visit_name)
53	13x	alt_dfs <- lapply(x[alt_names], list2df)
54	13x	alt <- do.call(rbind, alt_dfs)
55
56	13x	df_ref <- data.frame(
57	13x	visit = visit_name,
58	13x	group = group_names[1],
59	13x	est = ref$est,
60	13x	se_est = ref$se,
61	13x	lower_cl_est = ref$ci[1],
62	13x	upper_cl_est = ref$ci[2],
63	13x	est_contr = NA_real_,
64	13x	se_contr = NA_real_,
65	13x	lower_cl_contr = NA_real_,
66	13x	upper_cl_contr = NA_real_,
67	13x	p_value = NA_real_,
68	13x	relative_reduc = NA_real_,
69	13x	mse = NA_real_,
70	13x	df = NA_real_,
71	13x	stringsAsFactors = FALSE
72		)
73	13x	df_alt <- data.frame(
74	13x	visit = visit_name,
75	13x	group = group_names[-1],
76	13x	est = alt$est,
77	13x	se_est = alt$se,
78	13x	lower_cl_est = alt$ci_l,
79	13x	upper_cl_est = alt$ci_u,
80	13x	est_contr = contr$est,
81	13x	se_contr = contr$se,
82	13x	lower_cl_contr = contr$ci_l,
83	13x	upper_cl_contr = contr$ci_u,
84	13x	p_value = contr$pvalue,
85	13x	relative_reduc = contr$est / df_ref$est,
86	13x	mse = var$est,
87	13x	df = var$df,
88	13x	stringsAsFactors = FALSE
89		)
90	13x	rbind(df_ref, df_alt)
91		}
92
93		#' Helper method (for [`broom::tidy()`]) to prepare a data frame from an
94		#' `pool` `rbmi` object containing the LS means and contrasts and multiple visits
95		#'
96		#' @method tidy pool
97		#' @param x (`pool`) is a list of pooled object from `rbmi` analysis results. This list includes
98		#' analysis results, confidence level, hypothesis testing type.
99		#' @param visits (`character`)\cr all visit levels. Otherwise too hard to guess this.
100		#' @param ... Additional arguments. Not used. Needed to match generic signature only.
101		#' @importFrom generics tidy
102		#' @export
103		#' @keywords internal
104		#' @return A `data.frame`.
105		tidy.pool <- function(x, visits, ...) {
106	6x	ls_raw <- x$pars
107
108	6x	has_lsm <- grepl("^lsm_", names(ls_raw))
109	6x	has_first_visit <- grepl(paste0("_", visits[1]), names(ls_raw), fixed = TRUE)
110	6x	is_lsm_first_visit <- has_lsm & has_first_visit
111
112	6x	group_names <- names(ls_raw)[is_lsm_first_visit]
113	6x	group_names <- gsub(pattern = "^lsm_", replacement = "", x = group_names)
114	6x	group_names <- gsub(pattern = paste0("_", visits[1]), replacement = "", x = group_names, fixed = TRUE)
115
116	6x	spl <- rep(visits, each = length(ls_raw) / length(visits))
117
118	6x	ls_split <- split(ls_raw, spl)
119
120	6x	ls_df <- mapply(
121	6x	FUN = h_tidy_pool,
122	6x	x = ls_split,
123	6x	visit_name = visits,
124	6x	MoreArgs = list(group_names = group_names),
125	6x	SIMPLIFY = FALSE
126		)
127
128	6x	result <- do.call(rbind, unname(ls_df))
129
130	6x	result$visit <- factor(result$visit, levels = visits)
131	6x	result$group <- factor(result$group, levels = group_names)
132	6x	result$conf_level <- x$conf.level
133
134	6x	result
135		}
136
137		#' @describeIn tabulate_rbmi Statistics function which is extracting estimates
138		#' from a tidied RBMI results data frame.
139		#'
140		#' @param df (`data.frame`)\cr input with LS means results.
141		#' @param .in_ref_col (`flag`)\cr whether reference column is specified.
142		#' @param show_relative (`string`)\cr 'reduction' if (`control - treatment`, default)
143		#' or 'increase' (`treatment - control`) of relative change from baseline?
144		#' @return A list of statistics extracted from a tidied LS means data frame.
145		#' @export
146		s_rbmi_lsmeans <- function(df, .in_ref_col, show_relative = c("reduction", "increase")) {
147	7x	checkmate::assert_flag(.in_ref_col)
148
149	7x	show_relative <- match.arg(show_relative)
150	7x	if_not_ref <- function(x) if (.in_ref_col) character() else x
151	7x	list(
152	7x	adj_mean_se = c(df$est, df$se_est),
153	7x	adj_mean_ci = with_label(c(df$lower_cl_est, df$upper_cl_est), f_conf_level(df$conf_level)),
154	7x	diff_mean_se = if_not_ref(c(df$est_contr, df$se_contr)),
155	7x	diff_mean_ci = with_label(
156	7x	if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
157	7x	f_conf_level(df$conf_level)
158		),
159	7x	change = switch(
160	7x	show_relative,
161	7x	reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
162	7x	increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
163		),
164	7x	p_value = if_not_ref(df$p_value),
165	7x	additional_title_row = NULL
166		)
167		}
168
169		#' @describeIn tabulate_rbmi Formatted Analysis function which is used as `afun`.
170		#'
171		#' @inheritParams proposal_argument_convention
172		#' @export
173		a_rbmi_lsmeans <- function(
174		df,
175		ref_path,
176		.spl_context,
177		...,
178		.stats = NULL,
179		.formats = NULL,
180		.labels = NULL,
181		.indent_mods = NULL
182		) {
183		# Check for additional parameters to the statistics function
184	4x	dots_extra_args <- list(...)
185
186		# Only support default stats, not custom stats
187	4x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
188
189		# Obtain reference column information
190	4x	ref <- get_ref_info(ref_path, .spl_context)
191
192		# Apply statistics function
193	4x	x_stats <- .apply_stat_functions(
194	4x	default_stat_fnc = s_rbmi_lsmeans,
195	4x	custom_stat_fnc_list = NULL,
196	4x	args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
197		)
198
199		# Format according to specifications
200	4x	format_stats(
201	4x	x_stats,
202	4x	method_groups = "tabulate_rbmi",
203	4x	stats_in = .stats,
204	4x	formats_in = .formats,
205	4x	labels_in = .labels,
206	4x	indents_in = .indent_mods
207		)
208		}

1		#' Helpers for Processing Least Square Means
2		#'
3		#' @param fit result of model fitting function, e.g. [mmrm::mmrm()] or [stats::lm()].
4		#' @inheritParams fit_mmrm_j
5		#' @param averages (`list`)\cr optional named list of visit levels which should be averaged
6		#' and reported along side the single visits.
7		#' @param weights (`string`)\cr argument from [emmeans::emmeans()], 'counterfactual' by default.
8		#' @param specs (`list`)\cr list of least square means specifications, with
9		#' elements `coefs` (coefficient list) and `grid` (corresponding `data.frame`).
10		#' @param emmeans_res (`list`)\cr initial `emmeans` result from [h_get_emmeans_res()].
11		#'
12		#' @name lsmeans_helpers
13		#' @keywords internal
14		NULL
15
16		#' @describeIn lsmeans_helpers returns a list with
17		#' `object` (`emmGrid` object containing `emmeans` results) and `grid`
18		#' (`data.frame` containing the potential arm and the visit variables
19		#' together with the sample size `n` for each combination).
20		h_get_emmeans_res <- function(fit, vars, weights) {
21	30x	data_complete <- stats::model.frame(fit)
22	30x	checkmate::assert_data_frame(data_complete)
23	30x	checkmate::assert_list(vars)
24
25	30x	emmeans_object <- emmeans::emmeans(fit, data = data_complete, specs = c(vars$visit, vars$arm), weights = weights)
26
27		# Save grid with renamed number of subjects column.
28	30x	visit_arm_grid <- emmeans_object@grid
29	30x	wgt_index <- match(".wgt.", names(visit_arm_grid))
30	30x	names(visit_arm_grid)[wgt_index] <- "n"
31	30x	visit_arm_grid$n <- as.integer(visit_arm_grid$n)
32
33	30x	list(object = emmeans_object, grid = visit_arm_grid)
34		}
35
36		#' @describeIn lsmeans_helpers constructs average of visits specifications.
37		h_get_average_visit_specs <- function(emmeans_res, vars, averages, fit) {
38	4x	visit_grid <- emmeans_res$grid[[vars$visit]]
39	4x	model_frame <- stats::model.frame(fit)
40	4x	averages_list <- list()
41	4x	visit_vec <- n_vec <- c()
42	4x	if (!is.null(vars$arm)) {
43	4x	arm_grid <- emmeans_res$grid[[vars$arm]]
44	4x	arm_vec <- c()
45		}
46	4x	for (i in seq_along(averages)) {
47	5x	average_label <- names(averages)[i]
48	5x	visits_average <- averages[[i]]
49	5x	checkmate::assert_subset(visits_average, choices = levels(visit_grid))
50	5x	which_visits_in_average <- visit_grid %in% visits_average
51	5x	average_coefs <- as.integer(which_visits_in_average) / length(visits_average)
52	5x	zero_coefs <- numeric(length = length(average_coefs))
53
54	5x	if (is.null(vars$arm)) {
55	!	averages_list[[average_label]] <- average_coefs
56	!	visit_vec <- c(visit_vec, average_label)
57	!	is_in_subset <- (model_frame[[vars$visit]] %in% visits_average)
58	!	this_n <- length(unique(model_frame[is_in_subset, vars$id]))
59	!	n_vec <- c(n_vec, this_n)
60		} else {
61	5x	for (this_arm in levels(arm_grid)) {
62	10x	this_coefs <- zero_coefs
63	10x	arm_average_label <- paste(this_arm, average_label, sep = ".")
64	10x	which_arm <- arm_grid == this_arm
65	10x	this_coefs[which_arm] <- average_coefs[which_arm]
66	10x	averages_list[[arm_average_label]] <- this_coefs
67	10x	arm_vec <- c(arm_vec, this_arm)
68	10x	visit_vec <- c(visit_vec, average_label)
69	10x	is_in_subset <- (model_frame[[vars$arm]] == this_arm) & (model_frame[[vars$visit]] %in% visits_average)
70	10x	this_n <- length(unique(model_frame[is_in_subset, vars$id]))
71	10x	n_vec <- c(n_vec, this_n)
72		}
73		}
74		}
75	4x	if (is.null(vars$arm)) {
76	!	averages_grid <- data.frame(visit = visit_vec, n = n_vec)
77	!	names(averages_grid) <- c(vars$visit, "n")
78		} else {
79	4x	averages_grid <- data.frame(arm = arm_vec, visit = visit_vec, n = n_vec)
80	4x	names(averages_grid) <- c(vars$arm, vars$visit, "n")
81		}
82	4x	list(coefs = averages_list, grid = averages_grid)
83		}
84
85		#' @describeIn lsmeans_helpers estimates least square means as a `data.frame`
86		#' given specifications.
87		#'
88		#' @note The difference here compared to the original [tern.mmrm::h_get_spec_visit_estimates()]
89		#' function is that additional arguments for [emmeans::contrast()] can be passed via the
90		#' Once this has been added to the `tern.mmrm` package then its functions can be used instead.
91		#'
92		#' @param tests (`flag`)\cr whether to add test results to the estimates.
93		#' @param ... additional arguments for [emmeans::contrast()].
94		h_get_spec_visit_estimates <- function(emmeans_res, specs, conf_level, tests = FALSE, ...) {
95	38x	checkmate::assert_list(emmeans_res)
96	38x	checkmate::assert_list(specs)
97	38x	checkmate::assert_number(conf_level)
98	38x	checkmate::assert_flag(tests)
99
100	38x	conts <- emmeans::contrast(emmeans_res$object, specs$coefs, ...)
101	38x	cis <- stats::confint(conts, level = conf_level)
102	38x	res <- cbind(
103	38x	specs$grid,
104	38x	data.frame(estimate = cis$estimate, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL)
105		)
106	38x	if (tests) {
107	34x	conts_df <- as.data.frame(conts)
108	34x	res$t_stat <- conts_df$t.ratio
109	34x	res$p_value <- conts_df$p.value
110	34x	res$p_value_less <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = TRUE)
111	34x	res$p_value_greater <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = FALSE)
112		}
113	38x	res
114		}
115
116		#' @describeIn lsmeans_helpers estimates least square means for single visits.
117		h_get_single_visit_estimates <- function(emmeans_res, conf_level) {
118	30x	checkmate::assert_list(emmeans_res)
119	30x	checkmate::assert_number(conf_level)
120
121	30x	cis <- stats::confint(emmeans_res$object, level = conf_level)
122	30x	cbind(
123	30x	emmeans_res$grid[, setdiff(names(emmeans_res$grid), "n"), drop = FALSE],
124	30x	data.frame(estimate = cis$emmean, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL),
125	30x	emmeans_res$grid[, "n", drop = FALSE]
126		)
127		}
128
129		#' @describeIn lsmeans_helpers constructs `data.frame` with
130		#' relative reduction vs. reference arm based on single visit estimates.
131		#' @param estimates (`data.frame`)\cr single visit least square mean estimates.
132		h_get_relative_reduc_df <- function(estimates, vars) {
133	30x	checkmate::assert_data_frame(estimates)
134	30x	checkmate::assert_list(vars)
135
136	30x	ref_arm_level <- estimates[[vars$arm]][1L]
137	30x	ref_estimates <- estimates[estimates[[vars$arm]] == ref_arm_level, c(vars$visit, "estimate")]
138	30x	names(ref_estimates)[2L] <- "ref"
139	30x	result <- merge(estimates[estimates[[vars$arm]] != ref_arm_level, ], ref_estimates, by = vars$visit, sort = FALSE)
140	30x	result$relative_reduc <- (result$ref - result$estimate) / result$ref
141	30x	result[, c(vars$visit, vars$arm, "relative_reduc")]
142		}
143
144		#' @describeIn lsmeans_helpers constructs single visit contrast specifications.
145		h_single_visit_contrast_specs <- function(emmeans_res, vars) {
146	10x	checkmate::assert_list(emmeans_res)
147	10x	checkmate::assert_list(vars)
148
149	10x	emmeans_res$grid$index <- seq_len(nrow(emmeans_res$grid))
150
151	10x	grid_by_visit <- split(emmeans_res$grid, emmeans_res$grid[[vars$visit]])
152
153	10x	arm_levels <- emmeans_res$object@levels[[vars$arm]]
154	10x	ref_arm_level <- arm_levels[1L]
155	10x	zeros_coefs <- numeric(nrow(emmeans_res$grid))
156	10x	overall_list <- list()
157	10x	arm_vec <- visit_vec <- c()
158	10x	for (j in seq_along(grid_by_visit)) {
159	40x	this_grid <- grid_by_visit[[j]]
160	40x	ref_index <- which(this_grid[[vars$arm]] == ref_arm_level)
161	40x	this_visit <- names(grid_by_visit)[j]
162	40x	this_ref_coefs <- zeros_coefs
163	40x	this_ref_coefs[this_grid$index[ref_index]] <- -1
164	40x	this_list <- list()
165	40x	for (i in seq_len(nrow(this_grid))[-ref_index]) {
166	64x	this_coefs <- this_ref_coefs
167	64x	this_coefs[this_grid$index[i]] <- 1
168	64x	this_arm <- as.character(this_grid[[vars$arm]][i])
169	64x	arm_vec <- c(arm_vec, this_arm)
170	64x	visit_vec <- c(visit_vec, this_visit)
171	64x	this_label <- paste(this_arm, this_visit, sep = ".")
172	64x	this_list[[this_label]] <- this_coefs
173		}
174	40x	overall_list <- c(overall_list, this_list)
175		}
176
177	10x	grid <- data.frame(arm = arm_vec, visit = visit_vec)
178	10x	names(grid) <- c(vars$arm, vars$visit)
179	10x	list(coefs = overall_list, grid = grid)
180		}
181
182		#' @describeIn lsmeans_helpers constructs average visits contrast specifications,
183		#' given the `specs` for single visit contrasts and the averages required.
184		h_average_visit_contrast_specs <- function(specs, averages) {
185	4x	arm_visit_grid <- specs$grid
186	4x	arm_visit_grid$index <- seq_len(nrow(arm_visit_grid))
187	4x	grid_by_arm <- split(arm_visit_grid, arm_visit_grid[, 1L])
188	4x	overall_list <- list()
189	4x	arm_vec <- visit_vec <- c()
190	4x	for (j in seq_along(grid_by_arm)) {
191	4x	this_arm <- names(grid_by_arm)[j]
192	4x	this_grid <- grid_by_arm[[j]]
193	4x	for (i in seq_along(averages)) {
194	5x	average_label <- names(averages)[i]
195	5x	visits_average <- averages[[i]]
196	5x	which_visits_in_average <- this_grid[, 2L] %in% visits_average
197	5x	averaged_indices <- this_grid$index[which_visits_in_average]
198	5x	this_comb <- paste(this_arm, average_label, sep = ".")
199	5x	averaged_coefs <- colMeans(do.call(rbind, specs$coefs[averaged_indices]))
200	5x	overall_list[[this_comb]] <- averaged_coefs
201	5x	arm_vec <- c(arm_vec, this_arm)
202	5x	visit_vec <- c(visit_vec, average_label)
203		}
204		}
205
206	4x	grid <- data.frame(arm = arm_vec, visit = visit_vec)
207	4x	names(grid) <- names(arm_visit_grid[, c(1, 2)])
208
209	4x	list(coefs = overall_list, grid = grid)
210		}

1		#' Function Factory to Create Padded In Rows Content
2		#'
3		#' @param length_out (`count` or `NULL`)\cr full length which should be padded
4		#' by `NA` which will be printed as empty strings.
5		#' @param label (`string`)\cr row label to be used for the first row only.
6		#'
7		#' @return The function of `content` and `.formats`.
8		#' @keywords internal
9		pad_in_rows_fct <- function(length_out = NULL, label = "") {
10	144x	checkmate::assert_count(length_out, null.ok = TRUE)
11	144x	checkmate::assert_string(label)
12
13	144x	function(content, .formats) {
14	144x	content_list <- as.list(content)
15	144x	if (!is.null(length_out)) {
16	144x	missing_length <- length_out - length(content_list)
17	144x	if (missing_length > 0) {
18	23x	content_list <- c(content_list, rep(NA, missing_length))
19		}
20		}
21	144x	in_rows(
22	144x	.list = content_list,
23	144x	.names = as.character(seq_along(content_list)),
24	144x	.labels = c(
25	144x	label,
26	144x	rep(
27		"",
28	144x	length(content_list) -
29	144x	1L
30		)
31		),
32	144x	.formats = .formats,
33	144x	.format_na_strs = ""
34		)
35		}
36		}
37
38		#' First Level Column Split for LS Means Wide Table Layouts
39		#'
40		#' @inheritParams proposal_argument_convention
41		#'
42		#' @keywords internal
43		lsmeans_wide_first_split_fun_fct <- function(include_variance) {
44	3x	checkmate::assert_flag(include_variance)
45
46	3x	post_fun <- function(ret, spl, fulldf, .spl_context) {
47	3x	if (include_variance) {
48	2x	short_split_result(
49	2x	reference_group = "Reference Group",
50	2x	testing_group = "Testing Group",
51	2x	variance = "",
52	2x	comparison = "Testing - Reference",
53	2x	fulldf = fulldf
54		)
55		} else {
56	1x	short_split_result(
57	1x	reference_group = "Reference Group",
58	1x	testing_group = "Testing Group",
59	1x	comparison = "Testing - Reference",
60	1x	fulldf = fulldf
61		)
62		}
63		}
64	3x	make_split_fun(post = list(post_fun))
65		}
66
67		#' Second Level Column Split for LS Means Wide Table Layouts
68		#'
69		#' @inheritParams proposal_argument_convention
70		#' @param include_pval (`flag`)\cr whether to include the p-value column.
71		#'
72		#' @keywords internal
73		lsmeans_wide_second_split_fun_fct <- function(pval_sided, conf_level, include_pval) {
74	3x	checkmate::assert_flag(include_pval)
75
76	3x	post_fun <- function(ret, spl, fulldf, .spl_context) {
77	11x	colset <- .spl_context[nrow(.spl_context), "value"][[1]]
78	11x	if (colset %in% c("reference_group", "testing_group")) {
79	6x	short_split_result(treatment = "Treatment", n = "N", lsmean = "LS Mean", fulldf = fulldf)
80	5x	} else if (colset == "variance") {
81	2x	short_split_result(mse = "M. S. Error", df = "Error DF", fulldf = fulldf)
82		} else {
83	3x	if (include_pval) {
84	2x	short_split_result(
85	2x	lsmean = "LS Mean",
86	2x	se = "SE",
87	2x	ci = f_conf_level(conf_level),
88	2x	pval = paste0(abs(as.numeric(pval_sided)), "-sided p-value~[super a]"),
89	2x	fulldf = fulldf
90		)
91		} else {
92	1x	short_split_result(lsmean = "LS Mean", se = "SE", ci = f_conf_level(conf_level), fulldf = fulldf)
93		}
94		}
95		}
96	3x	make_split_fun(post = list(post_fun))
97		}
98
99		#' Content Row Analysis Function for LS Means Wide Table Layouts
100		#'
101		#' @inheritParams proposal_argument_convention
102		#' @param variables (`list`)\cr see [fit_ancova()] for required variable
103		#' specifications.
104		#' @param ref_level (`string`)\cr the reference level of the treatment arm variable.
105		#' @param treatment_levels (`character`)\cr the non-reference levels of the treatment arm
106		#' variable.
107		#' @param pval_sided (`string`)\cr either '2' for two-sided or '1' for 1-sided with greater than
108		#' control or '-1' for 1-sided with smaller than control alternative hypothesis.
109		#' @param formats (`list`)\cr including `lsmean`, `mse`, `df`, `lsmean_diff`, `se`,
110		#' `ci`, `pval` formats.
111		#'
112		#' @details This assumes a lot of structure of the layout, and is only intended to be used inside
113		#' [summarize_lsmeans_wide()], please see there for the layout structure that is needed.
114		#'
115		#' @keywords internal
116		lsmeans_wide_cfun <- function(
117		df,
118		labelstr,
119		.spl_context,
120		variables,
121		ref_level,
122		treatment_levels,
123		pval_sided = c("2", "1", "-1"),
124		conf_level,
125		formats
126		) {
127	144x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
128	144x	pad_in_rows <- pad_in_rows_fct(length_out = length(treatment_levels), label = labelstr)
129	144x	if (this_col_split[1] %in% c("reference_group", "testing_group")) {
130	75x	this_level <- if (this_col_split[1] == "reference_group") {
131	39x	ref_level
132		} else {
133	36x	treatment_levels
134		}
135	75x	has_this_level <- df[[variables$arm]] %in% this_level
136	75x	if (this_col_split[2] == "treatment") {
137	27x	pad_in_rows(this_level, .formats = "xx")
138	48x	} else if (this_col_split[2] == "n") {
139	24x	pad_in_rows(df$n[has_this_level], .formats = "xx")
140		} else {
141	24x	pad_in_rows(df$estimate_est[has_this_level], .formats = formats$lsmean)
142		}
143	69x	} else if (this_col_split[1] == "variance") {
144	20x	has_trt <- df[[variables$arm]] %in% treatment_levels
145	20x	all_the_same <- (length(unique(df$mse[has_trt])) == 1) && (length(unique(df$df[has_trt])) == 1)
146		# Note: We only take the first value, because in this ANCOVA case they are identical and we don't want to
147		# repeat it in the table.
148	20x	inds <- if (all_the_same) 1 else seq_len(sum(has_trt))
149	20x	if (this_col_split[2] == "mse") {
150	10x	pad_in_rows(df$mse[has_trt][inds], .formats = formats$mse)
151		} else {
152	10x	pad_in_rows(df$df[has_trt][inds], .formats = formats$df)
153		}
154		} else {
155	49x	has_trt <- df[[variables$arm]] %in% treatment_levels
156	49x	switch(this_col_split[2],
157	12x	"lsmean" = pad_in_rows(df$estimate_contr[has_trt], .formats = formats$lsmean_diff),
158	12x	"se" = pad_in_rows(df$se_contr[has_trt], .formats = formats$se),
159	12x	"ci" = pad_in_rows(
160	12x	tern::combine_vectors(df$lower_cl_contr[has_trt], df$upper_cl_contr[has_trt]),
161	12x	.formats = formats$ci
162		),
163		"pval" = {
164	13x	pval_sided <- match.arg(pval_sided)
165	13x	pval_col <- switch(pval_sided, `2` = "p_value", `1` = "p_value_greater", `-1` = "p_value_less")
166	13x	pad_in_rows(df[[pval_col]][has_trt], .formats = formats$pval)
167		}
168		)
169		}
170		}
171
172		#' Layout Generating Function for LS Means Wide Table Layouts
173		#'
174		#' @inheritParams proposal_argument_convention
175		#' @inheritParams lsmeans_wide_cfun
176		#' @param lyt empty layout, i.e. result of [rtables::basic_table()]
177		#' @param include_variance (`flag`)\cr whether to include the variance statistics
178		#' (M.S. error and d.f.).
179		#' @param include_pval (`flag`)\cr whether to include the p-value column.
180		#'
181		#' @return Modified layout.
182		#' @export
183		#' @examples
184		#' variables <- list(
185		#' response = 'FEV1',
186		#' covariates = c('RACE', 'SEX'),
187		#' arm = 'ARMCD',
188		#' id = 'USUBJID',
189		#' visit = 'AVISIT'
190		#' )
191		#' fit <- fit_ancova(
192		#' vars = variables,
193		#' data = mmrm::fev_data,
194		#' conf_level = 0.9,
195		#' weights_emmeans = 'equal'
196		#' )
197		#' anl <- broom::tidy(fit)
198		#' basic_table() \|>
199		#' summarize_lsmeans_wide(
200		#' variables = variables,
201		#' ref_level = fit$ref_level,
202		#' treatment_levels = fit$treatment_levels,
203		#' pval_sided = '2',
204		#' conf_level = 0.8
205		#' ) \|>
206		#' build_table(df = anl)
207		summarize_lsmeans_wide <- function(
208		lyt,
209		variables,
210		ref_level,
211		treatment_levels,
212		conf_level,
213		pval_sided = "2",
214		include_variance = TRUE,
215		include_pval = TRUE,
216		formats = list(
217		lsmean = jjcsformat_xx("xx.x"),
218		mse = jjcsformat_xx("xx.x"),
219		df = jjcsformat_xx("xx."),
220		lsmean_diff = jjcsformat_xx("xx.x"),
221		se = jjcsformat_xx("xx.xx"),
222		ci = jjcsformat_xx("(xx.xx, xx.xx)"),
223		pval = jjcsformat_pval_fct(0)
224		)
225		) {
226		# Check that all required format elements are present in the formats parameter
227	3x	checkmate::assert_names(
228	3x	names(formats),
229	3x	must.include = c("lsmean", "mse", "df", "lsmean_diff", "se", "ci", "pval"),
230	3x	.var.name = "formats"
231		)
232	3x	lyt \|>
233	3x	split_cols_by(
234	3x	variables$arm,
235	3x	split_fun = lsmeans_wide_first_split_fun_fct(include_variance = include_variance)
236		) \|>
237	3x	split_cols_by(
238	3x	variables$arm,
239	3x	split_fun = lsmeans_wide_second_split_fun_fct(
240	3x	include_pval = include_pval,
241	3x	pval_sided = pval_sided,
242	3x	conf_level = conf_level
243		)
244		) \|>
245	3x	split_rows_by(variables$visit, section_div = "") \|>
246	3x	summarize_row_groups(
247	3x	var = variables$arm,
248	3x	cfun = lsmeans_wide_cfun,
249	3x	extra_args = list(
250	3x	variables = variables,
251	3x	ref_level = ref_level,
252	3x	treatment_levels = treatment_levels,
253	3x	pval_sided = pval_sided,
254	3x	conf_level = conf_level,
255	3x	formats = formats
256		)
257		)
258		}

1		#' Get default statistical methods and their associated formats, labels, and indent modifiers
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' @note These functions have been copied from the `tern` package file
6		#' `utils_default_stats_formats_labels.R` from GitHub development version 0.9.7.9017.
7		#' Slight modifications have been applied to enhance functionality:
8		#'
9		#' * `tern_get_stats` added the `tern_stats` argument to avoid hardcoding within the function's body.
10		#' * `tern_get_labels_from_stats` is more careful when receiving partial `labels_in`
11		#' and partial `label_attr_from_stats`.
12		#'
13		#' Once these features are included in the `tern` package, this file could be removed from
14		#' the `junco` package, and the functions could be used from the `tern` namespace directly.
15		#'
16		#' @name tern_default_stats_formats_labels
17		NULL
18
19
20		# Utility function used to separate custom stats (user-defined functions) from defaults
21		.split_std_from_custom_stats <- function(stats_in) {
22	144x	out <- list(default_stats = NULL, custom_stats = NULL, all_stats = NULL)
23	144x	if (is.list(stats_in)) {
24	1x	is_custom_fnc <- sapply(stats_in, is.function)
25	1x	checkmate::assert_list(
26	1x	stats_in[is_custom_fnc],
27	1x	types = "function",
28	1x	names = "named"
29		)
30	1x	out[["custom_stats"]] <- stats_in[is_custom_fnc]
31	1x	out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc])
32	1x	all_stats <- names(stats_in) # to keep the order
33	1x	all_stats[!is_custom_fnc] <- out[["default_stats"]]
34	1x	out[["all_stats"]] <- all_stats
35		} else {
36	143x	out[["default_stats"]] <- out[["all_stats"]] <- stats_in
37		}
38	144x	out
39		}
40
41		# Utility function to apply statistical functions
42		.apply_stat_functions <- function(
43		default_stat_fnc,
44		custom_stat_fnc_list,
45		args_list
46		) {
47		# Default checks
48	144x	checkmate::assert_function(default_stat_fnc)
49	144x	checkmate::assert_list(
50	144x	custom_stat_fnc_list,
51	144x	types = "function",
52	144x	null.ok = TRUE,
53	144x	names = "named"
54		)
55	144x	checkmate::assert_list(args_list)
56
57		# Checking custom stats have same formals
58	144x	if (!is.null(custom_stat_fnc_list)) {
59	1x	fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]]
60	1x	for (fnc in custom_stat_fnc_list) {
61	1x	if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) {
62	!	stop(
63	!	"The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ",
64	!	"as the default statistical function. In this case your custom function has ",
65	!	names(formals(fnc))[[1]],
66	!	" as first parameter, while the default function has ",
67	!	fundamental_call_to_data,
68		"."
69		)
70		}
71	1x	if (!any(names(formals(fnc)) == "...")) {
72	!	stop(
73	!	"The custom statistical function needs to have `...` as a parameter to accept additional arguments. ",
74	!	"In this case your custom function does not have `...`."
75		)
76		}
77		}
78		}
79
80		# Applying
81	144x	out_default <- do.call(default_stat_fnc, args = args_list)
82	144x	out_custom <- lapply(
83	144x	custom_stat_fnc_list,
84	144x	function(fnc) do.call(fnc, args = args_list)
85		)
86
87		# Merging
88	144x	c(out_default, out_custom)
89		}
90
91		#' @describeIn tern_default_stats_formats_labels Get statistics available for a given method
92		#' group (analyze function).
93		#' @keywords internal
94		tern_get_stats <- function(
95		method_groups = "analyze_vars_numeric",
96		stats_in = NULL,
97		custom_stats_in = NULL,
98		add_pval = FALSE,
99		tern_defaults = tern_default_stats
100		) {
101	1111x	checkmate::assert_character(method_groups)
102	1111x	checkmate::assert_character(stats_in, null.ok = TRUE)
103	1111x	checkmate::assert_character(custom_stats_in, null.ok = TRUE)
104	1111x	checkmate::assert_flag(add_pval)
105
106		# Default is still numeric
107	1111x	if (any(method_groups == "analyze_vars")) {
108	3x	method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"
109		}
110
111	1111x	type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks
112
113		# Defaults for loop
114	1111x	out <- NULL
115
116		# Loop for multiple method groups
117	1111x	for (mgi in method_groups) {
118	1112x	if (mgi %in% names(tern_defaults)) {
119	1111x	out_tmp <- tern_defaults[[mgi]]
120		} else {
121	1x	stop(
122	1x	"The selected method group (",
123	1x	mgi,
124	1x	") has no default statistical method."
125		)
126		}
127	1111x	out <- unique(c(out, out_tmp))
128		}
129
130		# Add custom stats
131	1110x	out <- c(out, custom_stats_in)
132
133		# If you added pval to the stats_in you certainly want it
134	1110x	if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
135	21x	stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
136
137		# Must be only one value between choices
138	21x	checkmate::assert_choice(
139	21x	stats_in_pval_value,
140	21x	c("pval", "pval_counts", "pvalue")
141		)
142
143		# Mismatch with counts and numeric
144		if (
145	20x	any(grepl("counts", method_groups)) &&
146	20x	stats_in_pval_value != "pval_counts" \|\|
147	20x	any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval"
148		) {
149		# nolint
150	2x	stop(
151	2x	"Inserted p-value (",
152	2x	stats_in_pval_value,
153	2x	") is not valid for type ",
154	2x	type_tmp,
155	2x	". Use ",
156	2x	paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),
157	2x	" instead."
158		)
159		}
160
161		# Lets add it even if present (thanks to unique)
162	18x	add_pval <- TRUE
163		}
164
165		# Mainly used in "analyze_vars" but it could be necessary elsewhere
166	1107x	if (isTRUE(add_pval)) {
167	21x	if (any(grepl("counts", method_groups))) {
168	1x	out <- unique(c(out, "pval_counts"))
169		} else {
170	20x	out <- unique(c(out, "pval"))
171		}
172		}
173
174		# Filtering for stats_in (character vector)
175	1107x	if (!is.null(stats_in)) {
176	591x	out <- intersect(stats_in, out) # It orders them too
177		}
178
179		# If intersect did not find matches (and no pval?) -> error
180	1107x	if (length(out) == 0) {
181	2x	stop(
182	2x	"The selected method group(s) (",
183	2x	paste0(method_groups, collapse = ", "),
184		")",
185	2x	" do not have the required default statistical methods:\n",
186	2x	paste0(stats_in, collapse = " ")
187		)
188		}
189
190	1105x	out
191		}
192
193		#' @describeIn tern_default_stats_formats_labels Get formats corresponding to a list of statistics.
194		#' @keywords internal
195		tern_get_formats_from_stats <- function(
196		stats,
197		formats_in = NULL,
198		levels_per_stats = NULL,
199		tern_defaults = tern_default_formats
200		) {
201	636x	checkmate::assert_character(stats, min.len = 1)
202		# It may be a list if there is a function in the formats
203	636x	if (checkmate::test_list(formats_in, null.ok = TRUE)) {
204	635x	checkmate::assert_list(formats_in, null.ok = TRUE)
205		# Or it may be a vector of characters
206		} else {
207	1x	checkmate::assert_character(formats_in, null.ok = TRUE)
208		}
209	636x	checkmate::assert_list(levels_per_stats, null.ok = TRUE)
210
211		# If unnamed formats given as formats_in and same number of stats, use one format per stat
212		if (
213	636x	!is.null(formats_in) &&
214	636x	length(formats_in) == length(stats) &&
215	636x	is.null(names(formats_in)) &&
216	636x	is.null(levels_per_stats)
217		) {
218	!	out <- as.list(formats_in) \|> stats::setNames(stats)
219	!	return(out)
220		}
221
222		# If levels_per_stats not given, assume one row per statistic
223	153x	if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) \|> stats::setNames(stats)
224
225		# Apply custom formats
226	636x	out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults)
227
228		# Default to NULL if no format
229	636x	case_input_is_not_stat <- unlist(out, use.names = FALSE) == unlist(levels_per_stats, use.names = FALSE)
230	636x	out[names(out) == out \| case_input_is_not_stat] <- list(NULL)
231
232	636x	out
233		}
234
235		#' @describeIn tern_default_stats_formats_labels Get labels corresponding to a list of statistics.
236		#' @keywords internal
237		tern_get_labels_from_stats <- function(
238		stats,
239		labels_in = NULL,
240		levels_per_stats = NULL,
241		label_attr_from_stats = NULL,
242		tern_defaults = tern_default_labels
243		) {
244	596x	checkmate::assert_character(stats, min.len = 1)
245
246		# Modification:
247		# If any label_attr_from_stats is available and valid, save in labels_in
248		# if not specified there already (so don't overwrite labels_in).
249	596x	if (!is.null(label_attr_from_stats)) {
250	148x	valid_label_attr_from_stats <- label_attr_from_stats[
251	148x	nzchar(label_attr_from_stats) &
252	148x	!sapply(label_attr_from_stats, is.null) &
253	148x	!is.na(label_attr_from_stats)
254		]
255	148x	if (length(valid_label_attr_from_stats)) {
256	136x	do_save <- setdiff(
257	136x	names(valid_label_attr_from_stats),
258	136x	names(labels_in)
259		)
260	136x	labels_in <- c(labels_in, valid_label_attr_from_stats[do_save])
261		}
262		}
263
264		# It may be a list
265	596x	if (checkmate::test_list(labels_in, null.ok = TRUE)) {
266	571x	checkmate::assert_list(labels_in, null.ok = TRUE)
267		# Or it may be a vector of characters
268		} else {
269	25x	checkmate::assert_character(labels_in, null.ok = TRUE)
270		}
271	596x	checkmate::assert_list(levels_per_stats, null.ok = TRUE)
272
273		# If unnamed labels given as labels_in and same number of stats, use one label per stat
274		if (
275	596x	!is.null(labels_in) &&
276	596x	length(labels_in) == length(stats) &&
277	596x	is.null(names(labels_in)) &&
278	596x	is.null(levels_per_stats)
279		) {
280	!	out <- as.list(labels_in) \|> stats::setNames(stats)
281	!	return(out)
282		}
283
284		# If levels_per_stats not given, assume one row per statistic
285	156x	if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) \|> stats::setNames(stats)
286
287		# Apply custom labels
288	596x	out <- .fill_in_vals_by_stats(levels_per_stats, labels_in, tern_defaults)
289	596x	out
290		}
291
292		# Function to loop over each stat and levels to set correct values
293		.fill_in_vals_by_stats <- function(levels_per_stats, user_in, tern_defaults) {
294	1843x	out <- list()
295
296	1843x	for (stat_i in names(levels_per_stats)) {
297		# Get all levels of the statistic
298	3230x	all_lvls <- levels_per_stats[[stat_i]]
299
300	3230x	if ((length(all_lvls) == 1 && all_lvls == stat_i) \|\| is.null(all_lvls)) {
301		# One row per statistic
302	1946x	out[[stat_i]] <- if (stat_i %in% names(user_in)) {
303		# 1. Check for stat_i in user input
304	433x	user_in[[stat_i]]
305	1946x	} else if (stat_i %in% names(tern_defaults)) {
306		# 2. Check for stat_i in tern defaults
307	1504x	tern_defaults[[stat_i]]
308		} else {
309		# 3. Otherwise stat_i
310	9x	stat_i
311		}
312		} else {
313		# One row per combination of variable level and statistic
314		# Loop over levels for each statistic
315	1284x	for (lev_i in all_lvls) {
316		# Construct row name (stat_i.lev_i)
317	7115x	row_nm <- paste(stat_i, lev_i, sep = ".")
318
319	7115x	out[[row_nm]] <- if (row_nm %in% names(user_in)) {
320		# 1. Check for stat_i.lev_i in user input
321	1x	user_in[[row_nm]]
322	7115x	} else if (lev_i %in% names(user_in)) {
323		# 2. Check for lev_i in user input
324	5x	user_in[[lev_i]]
325	7115x	} else if (stat_i %in% names(user_in)) {
326		# 3. Check for stat_i in user input
327	1x	user_in[[stat_i]]
328	7115x	} else if (lev_i %in% names(tern_defaults)) {
329		# 4. Check for lev_i in tern defaults (only used for labels)
330	!	tern_defaults[[lev_i]]
331	7115x	} else if (stat_i %in% names(tern_defaults)) {
332		# 5. Check for stat_i in tern defaults
333	4712x	tern_defaults[[stat_i]]
334		} else {
335		# 6. Otherwise lev_i
336	2396x	lev_i
337		}
338		}
339		}
340		}
341
342	1843x	out
343		}
344
345		#' @describeIn tern_default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.
346		#' @keywords internal
347		tern_get_indents_from_stats <- function(stats,
348		indents_in = NULL,
349		levels_per_stats = NULL,
350		tern_defaults = as.list(rep(0L, length(stats))) \|> stats::setNames(stats)) {
351	630x	checkmate::assert_character(stats, min.len = 1)
352		# It may be a list
353	630x	if (checkmate::test_list(indents_in, null.ok = TRUE)) {
354	598x	checkmate::assert_list(indents_in, null.ok = TRUE)
355		# Or it may be a vector of integers
356		} else {
357	32x	checkmate::assert_integerish(indents_in, null.ok = TRUE)
358		}
359	630x	checkmate::assert_list(levels_per_stats, null.ok = TRUE)
360
361		# If levels_per_stats not given, assume one row per statistic
362	152x	if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) \|> stats::setNames(stats)
363
364		# Single indentation level for all rows
365	630x	if (is.null(names(indents_in)) && length(indents_in) == 1) {
366	19x	out <- rep(indents_in, length(levels_per_stats \|> unlist()))
367	19x	return(out)
368		}
369
370		# Apply custom indentation
371	611x	out <- .fill_in_vals_by_stats(levels_per_stats, indents_in, tern_defaults)
372	611x	out
373		}
374
375		# tern_default_labels ----
376
377		#' @describeIn tern_default_stats_formats_labels Named `character` vector of default labels for `tern`.
378		#' This is only copied here from the latest GitHub version, because otherwise a tern test fails.
379		#'
380		#' @keywords internal
381		tern_default_labels <- c(
382		cv = "CV (%)",
383		iqr = "IQR",
384		geom_cv = "CV % Geometric Mean",
385		geom_mean = "Geometric Mean",
386		geom_mean_sd = "Geometric Mean (SD)",
387		geom_mean_ci = "Geometric Mean 95% CI",
388		geom_mean_ci_3d = "Geometric Mean (95% CI)",
389		geom_sd = "Geometric SD",
390		mad = "Median Absolute Deviation",
391		max = "Maximum",
392		mean = "Mean",
393		mean_ci = "Mean 95% CI",
394		mean_ci_3d = "Mean (95% CI)",
395		mean_pval = "Mean p-value (H0: mean = 0)",
396		mean_sd = "Mean (SD)",
397		mean_sdi = "Mean -/+ 1xSD",
398		mean_se = "Mean (SE)",
399		mean_sei = "Mean -/+ 1xSE",
400		median = "Median",
401		median_ci = "Median 95% CI",
402		median_ci_3d = "Median (95% CI)",
403		median_range = "Median (Min - Max)",
404		min = "Minimum",
405		n = "n",
406		n_blq = "n_blq",
407		nonunique = "Number of events",
408		pval = "p-value (t-test)", # Default for numeric
409		pval_counts = "p-value (chi-squared test)", # Default for counts
410		quantiles = "25% and 75%-ile",
411		quantiles_lower = "25%-ile (95% CI)",
412		quantiles_upper = "75%-ile (95% CI)",
413		range = "Min - Max",
414		range_censor = "Range (censored)",
415		range_event = "Range (event)",
416		rate = "Adjusted Rate",
417		rate_ratio = "Adjusted Rate Ratio",
418		sd = "SD",
419		se = "SE",
420		sum = "Sum",
421		unique = "Number of patients with at least one event"
422		)

1		#' Statistical Function for Patient Years
2		#'
3		#' This function calculates patient years based on the provided data.
4		#'
5		#' @param df (`data.frame`)\cr data set containing all analysis variables.
6		#' @param .var (`string`)\cr variable name containing the patient years data.
7		#' @param id (`string`)\cr subject variable name.
8		#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
9		#' @param source (`string`)\cr source of data, either "alt_df" or "df".
10		#' @param inriskdiffcol (`logical`)\cr flag indicating if the function is called within a risk difference column.
11		#'
12		#' @return A list containing the patient years statistics.
13		#'
14		#' @keywords internal
15		s_patyrs_j <- function(
16		df,
17		.var,
18		id = "USUBJID",
19		.alt_df_full,
20		source = c("alt_df", "df"),
21		inriskdiffcol = FALSE
22		) {
23	5x	source <- match.arg(source)
24
25	5x	if (source == "alt_df") {
26	5x	if (is.null(.alt_df_full)) {
27	!	stop(paste(
28	!	"s_patyrs_j with source = alt_df requires a non-null .alt_df_full"
29		))
30		}
31	5x	df <- .alt_df_full
32		}
33	5x	df <- unique(df[, c(id, .var)])
34
35	5x	x <- list()
36
37	5x	if (!inriskdiffcol) {
38	3x	patyrs <- sum(df[[.var]])
39		} else {
40	2x	patyrs <- list(x = NULL)
41		}
42	5x	x[["patyrs"]] <- stats::setNames(patyrs, nm = "patyrs")
43
44	5x	return(x)
45		}
46
47		#' Calculate Patient Years
48		#'
49		#' This function calculates patient years based on the provided data.
50		#'
51		#' @param df (`data.frame`)\cr data set containing all analysis variables.
52		#' @param .var (`string`)\cr variable name containing the patient years data.
53		#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
54		#' @param id (`string`)\cr subject variable name.
55		#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
56		#' @param .formats (named 'character' or 'list')\cr formats for the statistics.
57		#' @param .labels (named 'character')\cr labels for the statistics.
58		#' @param source (`string`)\cr source of data, either "alt_df" or "df".
59		#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
60		#' @param .stats (`character`)\cr statistics to select for the table.
61		#'
62		#' @return A list of in_rows objects containing the patient years statistics.
63		#'
64		#' @export
65		#' @keywords internal
66		a_patyrs_j <- function(
67		df,
68		.var,
69		.df_row,
70		id = "USUBJID",
71		.alt_df_full = NULL,
72		.formats = NULL,
73		.labels = NULL,
74		source = c("alt_df", "df"),
75		.spl_context,
76		.stats = "patyrs"
77		) {
78	5x	source <- match.arg(source)
79
80	5x	if (length(.stats) > 1 \|\| (length(.stats) == 1 && .stats != "patyrs")) {
81	!	stop("a_patyrs_j: .stats must be 'patyrs'.")
82		}
83
84	5x	if (source == "alt_df" && is.null(.alt_df_full)) {
85	!	stop(paste(
86	!	"a_patyrs_j: .alt_df_full cannot be NULL when source = 'alt_df'."
87		))
88		}
89
90	5x	col_expr <- .spl_context$cur_col_expr[[1]]
91		## colid can be used to figure out if we're in the relative risk columns or not
92	5x	colid <- .spl_context$cur_col_id[[1]]
93	5x	inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)
94
95	5x	if (source == "alt_df") {
96		### derive appropriate alt_df based upon .spl_context and .alt_df_full
97		### note that this is not yet within the current column
98
99	5x	alt_df <- h_create_altdf(
100	5x	.spl_context,
101	5x	.df_row,
102	5x	.alt_df_full,
103	5x	denom_by = NULL,
104	5x	id = id,
105	5x	variables = NULL,
106	5x	denom = "n_altdf"
107		)
108		## restrict to current column
109	5x	new_denomdf <- subset(alt_df, eval(col_expr))
110		} else {
111	!	new_denomdf <- df
112		}
113
114	5x	x_stats <- s_patyrs_j(
115	5x	df,
116	5x	.alt_df_full = new_denomdf,
117	5x	.var = .var,
118	5x	id = id,
119	5x	source = source,
120	5x	inriskdiffcol = inriskdiffcol
121		)
122
123	5x	x_stats <- x_stats[.stats]
124
125	5x	levels_per_stats <- lapply(x_stats, names)
126
127	5x	.formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
128	5x	.labels <- junco_get_labels_from_stats(.stats, .labels, levels_per_stats)
129	5x	.labels <- .unlist_keep_nulls(.labels)
130
131	5x	x_stats <- x_stats[.stats]
132
133		# Unlist stats + names
134	5x	x_stats <- .unlist_keep_nulls(x_stats)
135	5x	names(x_stats) <- names(.formats)
136
137		### final step: turn requested stats into rtables rows
138	5x	inrows <- in_rows(
139	5x	.list = x_stats,
140	5x	.formats = .formats,
141	5x	.labels = .labels
142		)
143
144	5x	return(inrows)
145		}
146
147		#' Statistical Function for Exposure-Adjusted Incidence Rate
148		#'
149		#' This function calculates exposure-adjusted incidence rates (EAIR) per 100 person-years for a
150		#' specific level of a variable.
151		#'
152		#' @param levii (`string`)\cr the specific level of the variable to calculate EAIR for.
153		#' @param df (`data.frame`)\cr data set containing all analysis variables.
154		#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
155		#' @param .var (`string`)\cr variable name that is passed by `rtables`.
156		#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
157		#' @param id (`string`)\cr subject variable name.
158		#' @param diff (`logical`)\cr if TRUE, risk difference calculations will be performed.
159		#' @param conf_level (`proportion`)\cr confidence level of the interval.
160		#' @param trt_var (`string`)\cr treatment variable name.
161		#' @param ctrl_grp (`string`)\cr control group value.
162		#' @param cur_trt_grp (`string`)\cr current treatment group value.
163		#' @param inriskdiffcol (`logical`)\cr flag indicating if the function is called within a risk difference column.
164		#' @param fup_var (`string`)\cr follow-up variable name.
165		#' @param occ_var (`string`)\cr occurrence variable name.
166		#' @param occ_dy (`string`)\cr occurrence day variable name.
167		#'
168		#' @return A list containing the following statistics:
169		#' \itemize{
170		#' \item n_event: Number of events
171		#' \item person_years: Total person-years of follow-up
172		#' \item eair: Exposure-adjusted incidence rate per 100 person-years
173		#' \item eair_diff: Risk difference in EAIR (if diff=TRUE and inriskdiffcol=TRUE)
174		#' \item eair_diff_ci: Confidence interval for the risk difference (if diff=TRUE and inriskdiffcol=TRUE)
175		#' }
176		#'
177		#' @keywords internal
178		s_eair100_levii_j <- function(
179		levii,
180		df,
181		.df_row,
182		.var,
183		.alt_df_full = NULL,
184		id = "USUBJID",
185		diff = FALSE,
186		# treatment/ref group related arguments
187		conf_level = 0.95,
188		trt_var = NULL,
189		ctrl_grp = NULL,
190		cur_trt_grp = NULL,
191		inriskdiffcol = FALSE,
192		fup_var,
193		occ_var,
194		occ_dy
195		) {
196	150x	if (diff && inriskdiffcol) {
197	60x	.alt_df_full_cur_group <- get_ctrl_subset(
198	60x	.alt_df_full,
199	60x	trt_var = trt_var,
200	60x	ctrl_grp = cur_trt_grp
201		)
202		} else {
203		### within a_eair100_j we need to ensure proper dataframe will be passed to .alt_df_full
204	90x	.alt_df_full_cur_group <- .alt_df_full
205		}
206	150x	cur_dfs <- h_get_eair_df(
207	150x	levii,
208	150x	df,
209	150x	denom_df = .alt_df_full_cur_group,
210	150x	.var = .var,
211	150x	id = id,
212	150x	fup_var = fup_var,
213	150x	occ_var = occ_var,
214	150x	occ_dy = occ_dy
215		)
216	150x	cur_df_num <- cur_dfs$df_num
217	150x	cur_df_denom <- cur_dfs$df_denom
218
219		### statistics derivation
220	150x	cur_AECOUNT <- length(unique(cur_df_num[[id]]))
221	150x	cur_YRSFUP <- sum(cur_df_denom[["mod_fup_var"]])
222	150x	cur_eair <- 100 * cur_AECOUNT / cur_YRSFUP
223
224	150x	x <- list()
225	150x	x$n_event <- c("n_event" = cur_AECOUNT)
226	150x	x$person_years <- c("person_years" = cur_YRSFUP)
227	150x	x$eair <- c("eair" = cur_eair)
228
229	150x	if (diff && inriskdiffcol) {
230	60x	x$n_event <- c("n_event" = NULL)
231	60x	x$person_years <- c("person_years" = NULL)
232	60x	x$eair <- c("eair" = NULL)
233
234	60x	alt_df_full_ref_group <- get_ctrl_subset(
235	60x	.alt_df_full,
236	60x	trt_var = trt_var,
237	60x	ctrl_grp = ctrl_grp
238		)
239
240	60x	ref_group <- get_ctrl_subset(
241	60x	.df_row,
242	60x	trt_var = trt_var,
243	60x	ctrl_grp = ctrl_grp
244		)
245
246	60x	ref_dfs <- h_get_eair_df(
247	60x	levii,
248	60x	df = ref_group,
249	60x	denom_df = alt_df_full_ref_group,
250	60x	.var = .var,
251	60x	id = id,
252	60x	fup_var = fup_var,
253	60x	occ_var = occ_var,
254	60x	occ_dy = occ_dy
255		)
256
257	60x	ref_df_num <- ref_dfs$df_num
258	60x	ref_df_denom <- ref_dfs$df_denom
259
260		### statistics derivation
261	60x	ref_AECOUNT <- length(unique(ref_df_num[[id]]))
262	60x	ref_YRSFUP <- sum(ref_df_denom[["mod_fup_var"]])
263	60x	ref_eair <- 100 * ref_AECOUNT / ref_YRSFUP
264
265	60x	rdiff <- cur_eair - ref_eair
266
267	60x	sd <- sqrt(cur_AECOUNT / cur_YRSFUP^2 + ref_AECOUNT / ref_YRSFUP^2) * 100
268
269	60x	coeff <- stats::qnorm((1 + conf_level) / 2)
270	60x	lcl <- rdiff - (coeff * sd)
271	60x	ucl <- rdiff + (coeff * sd)
272
273	60x	eair_diff <- c(rdiff, lcl, ucl)
274
275	60x	x$eair_diff <- stats::setNames(
276	60x	c("eair_diff" = eair_diff),
277	60x	nm = c("estimate", "lcl", "ucl")
278		)
279		} else {
280	90x	x$eair_diff <- c("eair_diff" = NULL)
281		}
282
283	150x	return(x)
284		}
285
286		#' Calculate Exposure-Adjusted Incidence Rate per 100 Patient-Years
287		#'
288		#' This function calculates the exposure-adjusted incidence rate (EAIR) per 100 patient-years.
289		#' It can also calculate the difference in EAIR between treatment groups.
290		#'
291		#' @param df (`data.frame`)\cr data set containing all analysis variables.
292		#' @param labelstr (`string`)\cr label string for the row.
293		#' @param .var (`string`)\cr variable name for analysis.
294		#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
295		#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
296		#' @param .alt_df_full (`dataframe`)\cr denominator dataset for calculations.
297		#' @param id (`string`)\cr subject variable name.
298		#' @param drop_levels (`logical`)\cr if TRUE, non-observed levels will not be included.
299		#' @param riskdiff (`logical`)\cr if TRUE, risk difference calculations will be performed.
300		#' @param ref_path (`string`)\cr column path specifications for the control group.
301		#' @param .stats (`character`)\cr statistics to select for the table.
302		#' @param .formats (named 'character' or 'list')\cr formats for the statistics.
303		#' @param .labels (named 'character')\cr labels for the statistics.
304		#' @param .indent_mods (named `integer`)\cr indent modifiers for the labels.
305		#' @param na_str (`string`)\cr string used to replace all NA or empty values in the output.
306		#' @param conf_level (`proportion`)\cr confidence level of the interval.
307		#' @param fup_var (`string`)\cr variable name for follow-up time.
308		#' @param occ_var (`string`)\cr variable name for occurrence.
309		#' @param occ_dy (`string`)\cr variable name for occurrence day.
310		#'
311		#' @return A list of in_rows objects containing the EAIR statistics.
312		#'
313		#' @export
314		#' @keywords internal
315		a_eair100_j <- function(
316		df,
317		labelstr = NULL,
318		.var,
319		.df_row,
320		.spl_context,
321		.alt_df_full = NULL,
322		id = "USUBJID",
323		drop_levels = FALSE,
324		riskdiff = TRUE,
325		ref_path = NULL,
326		.stats = c("eair"),
327		.formats = NULL,
328		.labels = NULL,
329		.indent_mods = NULL,
330		na_str = rep("NA", 3),
331		# treatment/ref group related arguments
332		conf_level = 0.95,
333		fup_var,
334		occ_var,
335		occ_dy
336		) {
337		## prepare for column based split
338	15x	col_expr <- .spl_context$cur_col_expr[[1]]
339		## colid can be used to figure out if we're in the relative risk columns or not
340	15x	colid <- .spl_context$cur_col_id[[1]]
341	15x	inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)
342
343		# if no stats requested, get all stats
344	15x	.stats <- junco_get_stats(
345	15x	"a_eair100_j",
346	15x	stats_in = .stats,
347	15x	custom_stats_in = NULL
348		)
349
350		### combine all preprocessing of incoming df/.df_row in one function
351		### do this outside stats derivation functions (s_freq_j/)
352		### use all of val/excl_levels/drop_levels//new_levels/label/label_map/labelstr/label_fstr
353	15x	upd_dfrow <- h_upd_dfrow(
354	15x	.df_row,
355	15x	.var,
356	15x	val = NULL,
357	15x	excl_levels = NULL,
358	15x	drop_levels = drop_levels,
359	15x	new_levels = NULL,
360	15x	new_levels_after = FALSE,
361	15x	label = NULL,
362	15x	label_map = NULL,
363	15x	labelstr = labelstr,
364	15x	label_fstr = NULL,
365	15x	.spl_context = .spl_context
366		)
367
368	15x	.df_row <- upd_dfrow$df_row
369	15x	df <- upd_dfrow$df
370
371	15x	if (is.null(.alt_df_full)) {
372	!	stop(paste("a_eair100_j: .alt_df_full cannot be NULL."))
373		}
374
375		### derive appropriate alt_df based upon .spl_context and .alt_df_full
376		### note that only row-based splits are done
377		### for now only for variables from the first split_rows_by
378	15x	alt_df <- h_create_altdf(
379	15x	.spl_context,
380	15x	.df_row,
381	15x	.alt_df_full,
382	15x	denom_by = NULL,
383	15x	id = id,
384	15x	variables = NULL,
385	15x	denom = "n_altdf"
386		)
387	15x	new_denomdf <- alt_df
388
389	15x	fn_Args <- list(
390	15x	df = df,
391	15x	.df_row = .df_row,
392	15x	.var = .var,
393	15x	id = id,
394	15x	diff = riskdiff,
395	15x	inriskdiffcol = inriskdiffcol,
396	15x	fup_var = fup_var,
397	15x	occ_var = occ_var,
398	15x	occ_dy = occ_dy
399		)
400
401	15x	if (riskdiff && inriskdiffcol) {
402	6x	trt_var_refpath <- h_get_trtvar_refpath(
403	6x	ref_path,
404	6x	.spl_context,
405	6x	df
406		)
407		# trt_var_refpath is list with elements
408		# trt_var trt_var_refspec cur_trt_grp ctrl_grp
409		# make these elements available in current environment
410	6x	trt_var <- trt_var_refpath$trt_var
411	6x	trt_var_refspec <- trt_var_refpath$trt_var_refspec
412	6x	cur_trt_grp <- trt_var_refpath$cur_trt_grp
413	6x	ctrl_grp <- trt_var_refpath$ctrl_grp
414
415	6x	fn_args_x <- list(
416	6x	.alt_df_full = .alt_df_full,
417		# treatment/ref group related arguments
418	6x	conf_level = conf_level,
419	6x	trt_var = trt_var,
420	6x	ctrl_grp = ctrl_grp,
421	6x	cur_trt_grp = cur_trt_grp
422		)
423		} else {
424	9x	new_denomdf <- subset(new_denomdf, eval(col_expr))
425	9x	fn_args_x <- list(.alt_df_full = new_denomdf)
426		}
427
428	15x	fn_Args <- append(fn_Args, fn_args_x)
429
430	15x	levs <- levels(.df_row[[.var]])
431	15x	y <- mapply(
432	15x	s_eair100_levii_j,
433	15x	levii = levs,
434	15x	MoreArgs = fn_Args,
435	15x	SIMPLIFY = FALSE
436		)
437
438		### rearrange list y to list to x_stats
439		#### this is to ensure the remainder of the code can stay the same as in a_freq_j
440	15x	stnms <- c("eair", "eair_diff", "n_event", "person_years")
441	15x	x_stats <- extract_x_stats(y, stnms)
442
443	15x	if (!inriskdiffcol) {
444	9x	.stats_adj <- .stats
445		} else {
446	6x	.stats_adj <- replace(.stats, .stats %in% c("eair"), "eair_diff")
447		}
448
449	15x	.stats <- .stats_adj
450
451		# Fill in formatting defaults
452
453	15x	if (length(levs) > 1 && length(.stats) > 1) {
454	!	message(
455	!	"a_eair100_j : with multiple stats and multiple levels of analysis
456	!	variable it is recommended to apply an extra split_rows_by on the analysis variable"
457		)
458		}
459
460	15x	x_stats <- x_stats[.stats]
461
462	15x	levels_per_stats <- lapply(x_stats, names)
463
464	15x	.formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
465	15x	.labels <- junco_get_labels_from_stats(.stats, .labels, levels_per_stats)
466	15x	.labels <- .unlist_keep_nulls(.labels)
467
468	15x	.indent_mods <- junco_get_indents_from_stats(
469	15x	.stats,
470	15x	.indent_mods,
471	15x	levels_per_stats
472		)
473	15x	.indent_mods <- .unlist_keep_nulls(.indent_mods)
474
475		# .format_na_strs processing
476		# if na_str = c(NA, NA, NA)
477		# this will ensure the ci (NA, NA, NA) will be represented as NE (NE, NE)
478		# the value NE is defined as the default to replace NA in our jjcs format
479
480	15x	if (!is.null(na_str)) {
481	15x	.format_na_strs <- lapply(names(.formats), FUN = function(x) {
482	150x	na_str
483		})
484		} else {
485	!	.format_na_strs <- NULL
486		}
487
488		# Unlist stats + names
489	15x	x_stats <- .unlist_keep_nulls(x_stats)
490	15x	names(x_stats) <- names(.formats)
491
492		### final step: turn requested stats into rtables rows
493	15x	inrows <- in_rows(
494	15x	.list = x_stats,
495	15x	.formats = .formats,
496	15x	.labels = .labels,
497	15x	.indent_mods = .indent_mods,
498	15x	.format_na_strs = .format_na_strs
499		)
500
501	15x	return(inrows)
502		}

1		#' Extract Estimates from Multivariate Cox Regression Model Fit Object
2		#'
3		#' @param x (`coxreg.multivar`)\cr from [tern::fit_coxreg_multivar()].
4		#' @export
5		#' @return A data frame containing Cox regression results with columns for term,
6		#' coef_se (coefficient and standard error), p.value, hr (hazard ratio),
7		#' hr_ci (confidence interval for hazard ratio), and labels (formatted term labels).
8		#' @keywords internal
9		#'
10		#' @examples
11		#' anl <- tern::tern_ex_adtte \|>
12		#' dplyr::mutate(EVENT = 1 - CNSR)
13		#'
14		#' variables <- list(
15		#' time = 'AVAL',
16		#' event = 'EVENT',
17		#' arm = 'ARM',
18		#' covariates = c('SEX', 'AGE')
19		#' )
20		#'
21		#' control <- tern::control_coxreg(
22		#' conf_level = 0.9,
23		#' ties = 'efron'
24		#' )
25		#'
26		#' fit <- tern::fit_coxreg_multivar(
27		#' data = anl,
28		#' variables = variables,
29		#' control = control
30		#' )
31		#'
32		#' h_extract_coxreg_multivar(fit)
33		h_extract_coxreg_multivar <- function(x) {
34	22x	checkmate::assert_class(x, "coxreg.multivar")
35	22x	vars <- c(x$vars$arm, x$vars$covariates)
36
37		# Extract the table.
38	22x	tab <- broom::tidy(x$mod, exponentiate = FALSE, conf.int = TRUE, conf.level = x$control$conf_level)
39	22x	tab$hr <- exp(tab$estimate)
40	22x	tab$hr_ci <- Map(lcl = exp(tab$conf.low), ucl = exp(tab$conf.high), f = function(lcl, ucl) c(lcl, ucl))
41	22x	tab$coef_se <- Map(coef = tab$estimate, se = tab$std.error, f = function(coef, se) c(coef, se))
42	22x	colnms <- c("term", "coef_se", "p.value", "hr", "hr_ci")
43	22x	tab <- tab[, colnms, drop = FALSE]
44
45		# Format nicely the term labels.
46	22x	var_to_term <- sapply(vars, function(v) which(startsWith(tab$term, v)), USE.NAMES = TRUE, simplify = FALSE)
47	22x	tab$labels <- unlist(lapply(vars, function(v) {
48	67x	inds <- var_to_term[[v]]
49	67x	strip_term <- gsub(paste0("^", v), "", tab$term[inds])
50	67x	this_df <- x$dat[v]
51	67x	if (is.character(this_df[[1]])) {
52	1x	this_df[[1]] <- as.factor(this_df[[1]])
53		}
54	67x	if (is.factor(this_df[[1]])) {
55	45x	ref_level <- levels(this_df[[1]])[1]
56	45x	var_name <- if (v == x$vars$arm) "Treatment" else labels_or_names(this_df)
57	45x	paste0(var_name, " (", strip_term, " vs. ", ref_level, ")")
58		} else {
59	22x	labels_or_names(this_df)
60		}
61		}))
62	22x	tab
63		}
64
65		#' First Level Column Split Function for TEFOS03 (mmy) Table Layout
66		#' @seealso [rtables::make_split_fun()] for details.
67		#' @keywords internal
68		tefos03_first_post_fun <- function(ret, spl, fulldf, .spl_context) {
69	5x	all_expr <- expression(TRUE)
70	5x	short_split_result(model_fit = "Model Fit", hazard_ratio = "Hazard Ratio", fulldf = fulldf)
71		}
72		tefos03_first_split_fun <- make_split_fun(post = list(tefos03_first_post_fun))
73
74		#' Second Level Column Split Function Factory for TEFOS03 (mmy) Table Layout
75		#'
76		#' @inheritParams proposal_argument_convention
77		#'
78		#' @return Split function to use in the TEFOS03 (mmy) and related table layouts.
79		#'
80		#' @seealso [tefos03_first_post_fun()] for the first level split.
81		#' @keywords internal
82		tefos03_second_split_fun_fct <- function(conf_level) {
83	4x	post_fun <- function(ret, spl, fulldf, .spl_context) {
84	8x	all_expr <- expression(TRUE)
85	8x	colset <- .spl_context[nrow(.spl_context), "value"][[1]]
86	8x	if (colset == "model_fit") {
87	4x	short_split_result(coef_se = "Coeff. (SE)", pval = "p-value", fulldf = fulldf)
88		} else {
89	4x	short_split_result(hr_est = "Estimate", hr_ci = f_conf_level(conf_level), fulldf = fulldf)
90		}
91		}
92	4x	make_split_fun(post = list(post_fun))
93		}
94
95		#' @keywords internal
96		memoised_fit_coxreg_multivar <- memoise::memoise(fit_coxreg_multivar)
97
98		#' Analysis Function for TEFOS03 and Related Table Layouts
99		#'
100		#' @inheritParams proposal_argument_convention
101		#' @param control (`list`)\cr from [tern::control_coxreg()].
102		#' @param formats (`list`)\cr including `coef_se`, `hr_est`, `hr_ci` and `pval` formats.
103		#' @param variables (`list`)\cr see [tern::fit_coxreg_multivar()] for required variable
104		#' specifications.
105		#'
106		#' @keywords internal
107		tefos03_afun <- function(df, .var, .spl_context, variables, control, formats) {
108	21x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
109	21x	model_fit <- memoised_fit_coxreg_multivar(data = df, variables = variables, control = control)
110	21x	tab <- h_extract_coxreg_multivar(model_fit)
111	21x	if (this_col_split[1] == "model_fit") {
112	11x	if (this_col_split[2] == "coef_se") {
113	5x	in_rows(.list = tab$coef_se, .formats = formats$coef_se, .labels = tab$labels)
114		} else {
115	6x	in_rows(.list = tab$p.value, .formats = formats$pval, .labels = tab$labels)
116		}
117		} else {
118	10x	if (this_col_split[2] == "hr_est") {
119	5x	in_rows(.list = tab$hr, .formats = formats$hr_est, .labels = tab$labels)
120		} else {
121	5x	in_rows(.list = tab$hr_ci, .formats = formats$hr_ci, .labels = tab$labels)
122		}
123		}
124		}
125
126		#' Layout Generating Function for TEFOS03 and Related Cox Regression Layouts
127		#'
128		#' @inheritParams proposal_argument_convention
129		#' @inheritParams tefos03_afun
130		#' @param var (`string`)\cr any variable from the data, because this is not used.
131		#'
132		#' @return Modified layout.
133		#' @export
134		#' @examples
135		#' anl <- tern::tern_ex_adtte \|>
136		#' dplyr::mutate(EVENT = 1 - CNSR)
137		#'
138		#' variables <- list(
139		#' time = 'AVAL',
140		#' event = 'EVENT',
141		#' arm = 'ARM',
142		#' covariates = c('SEX', 'AGE')
143		#' )
144		#'
145		#' basic_table() \|>
146		#' summarize_coxreg_multivar(
147		#' var = 'STUDYID',
148		#' variables = variables
149		#' ) \|>
150		#' build_table(df = anl)
151		summarize_coxreg_multivar <- function(
152		lyt,
153		var,
154		variables,
155		control = control_coxreg(),
156		formats = list(
157		coef_se = jjcsformat_xx("xx.xx (xx.xx)"),
158		hr_est = jjcsformat_xx("xx.xx"),
159		hr_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
160		pval = jjcsformat_pval_fct(0)
161		)
162		) {
163	3x	second_split_fun <- tefos03_second_split_fun_fct(conf_level = control$conf_level)
164	3x	lyt \|>
165	3x	split_cols_by(var = var, split_fun = tefos03_first_split_fun) \|>
166	3x	split_cols_by(var = var, split_fun = second_split_fun) \|>
167	3x	analyze(
168	3x	vars = var,
169	3x	var_labels = "Model Parameter",
170	3x	show_labels = "visible",
171	3x	afun = tefos03_afun,
172	3x	extra_args = list(variables = variables, control = control, formats = formats)
173		)
174		}

1		#' MMRM Analysis for Imputed Datasets
2		#'
3		#' Performs an MMRM for two or more groups returning the estimated
4		#' 'treatment effect' (i.e. the contrast between treatment groups and the control
5		#' group) and the least square means estimates in each group.
6		#'
7		#' @param data (`data.frame`)\cr containing the data to be used in the model.
8		#' @param vars (`vars`)\cr list as generated by [set_vars()]. Only the `subjid`, `group`,
9		#' `visit`, `outcome` and `covariates` elements are required. See details.
10		#' @param cov_struct (`string`)\cr the covariance structure to use. Note that the same
11		#' covariance structure is assumed for all treatment groups.
12		#' @param visits (`NULL` or `character`)\cr An optional character vector specifying
13		#' which visits to fit the MMRM at. If `NULL`, the MMRM model will be fit to
14		#' the whole dataset.
15		#' @param weights (`string`)\cr the weighting strategy to be used when calculating the
16		#' least square means, either `'counterfactual'` or `'equal'`.
17		#' @param ... additional arguments passed to [mmrm::mmrm()], in particular
18		#' `method` and `vcov` to control the degrees of freedom and variance-covariance
19		#' adjustment methods as well as `reml` decide between REML and ML estimation.
20		#'
21		#' @details
22		#' The function works as follows:
23		#'
24		#' 1. Optionally select the subset of the `data` corresponding to `visits.
25		#' 2. Fit an MMRM as `vars$outcome ~ vars$group + vars$visit + vars$covariates`
26		#' with the specified covariance structure for visits within subjects.
27		#' 3. Extract the 'treatment effect' & least square means for each treatment group
28		#' vs the control group.
29		#'
30		#' In order to meet the formatting standards set by [analyse()] the results will be collapsed
31		#' into a single list suffixed by the visit name, e.g.:
32		#' ```
33		#' list(
34		#' var_B_visit_1 = list(est = ...),
35		#' trt_B_visit_1 = list(est = ...),
36		#' lsm_A_visit_1 = list(est = ...),
37		#' lsm_B_visit_1 = list(est = ...),
38		#' var_B_visit_2 = list(est = ...),
39		#' trt_B_visit_2 = list(est = ...),
40		#' lsm_A_visit_2 = list(est = ...),
41		#' lsm_B_visit_2 = list(est = ...),
42		#' ...
43		#' )
44		#' ```
45		#' Please note that 'trt' refers to the treatment effects, and 'lsm' refers to the least
46		#' square mean results. In the above example `vars$group` has two factor levels A and B.
47		#' The new 'var' refers to the model estimated variance of the residuals at the given
48		#' visit, together with the degrees of freedom (which is treatment group specific).
49		#'
50		#' If you want to include additional interaction terms in your model this can be done
51		#' by providing them to the `covariates` argument of [set_vars()]
52		#' e.g. `set_vars(covariates = c('sex*age'))`.
53		#'
54		#' @note The `group` and `visit` interaction `group:visit` is not included by
55		#' default in the model, therefore please add that to `covariates` manually if
56		#' you want to include it. This will make sense in most cases.
57		#'
58		#' @seealso [rbmi_analyse()]
59		#' @seealso [mmrm::mmrm()]
60		#' @seealso [set_vars()]
61		#' @export
62		rbmi_mmrm <- function(
63		data,
64		vars,
65		cov_struct = c("us", "toep", "cs", "ar1"),
66		visits = NULL,
67		weights = c("counterfactual", "equal"),
68		...
69		) {
70	1x	subjid <- vars[["subjid"]]
71	1x	outcome <- vars[["outcome"]]
72	1x	group <- vars[["group"]]
73	1x	visit <- vars[["visit"]]
74	1x	covariates <- vars[["covariates"]]
75
76	1x	checkmate::assert_string(subjid)
77	1x	checkmate::assert_string(outcome)
78	1x	checkmate::assert_string(group)
79	1x	checkmate::assert_string(visit)
80	1x	checkmate::assert_character(covariates, null.ok = TRUE)
81
82	1x	cov_struct <- match.arg(cov_struct)
83	1x	weights <- match.arg(weights)
84
85	1x	expected_vars <- c((utils::getFromNamespace("extract_covariates", "rbmi"))(covariates), outcome, group, subjid, visit)
86	1x	checkmate::assert_subset(expected_vars, names(data))
87
88	1x	checkmate::assert_factor(data[[visit]])
89	1x	if (is.null(visits)) {
90	1x	visits <- as.character(unique(data[[visit]]))
91		}
92	1x	checkmate::assert_subset(visits, as.character(data[[visit]]))
93	1x	data <- data[data[[visit]] %in% visits, , drop = FALSE]
94
95	1x	covariates_part <- paste(covariates, collapse = " + ")
96	1x	grp_visit_part <- paste(group, "+", visit)
97	1x	random_effects_part <- paste0(cov_struct, "(", visit, " \| ", subjid, ")")
98	1x	rhs_formula <- paste(grp_visit_part, "+", random_effects_part)
99	1x	if (covariates_part != "") rhs_formula <- paste(covariates_part, "+", rhs_formula)
100	1x	formula <- stats::as.formula(paste(outcome, "~", rhs_formula))
101
102	1x	fit <- mmrm::mmrm(formula, data = data, ...)
103	1x	res <- lapply(visits, function(x) {
104	3x	res <- rbmi_mmrm_single_info(fit, visit_level = x, visit = visit, group = group, weights = weights)
105	3x	names(res) <- paste0(names(res), "_", x)
106	3x	return(res)
107		})
108	1x	unlist(res, recursive = FALSE)
109		}
110
111		#' Extract Single Visit Information from a Fitted MMRM for Multiple Imputation Analysis
112		#'
113		#' @description
114		#' Extracts relevant estimates from a given fitted MMRM. See [rbmi_mmrm()] for full details.
115		#'
116		#' @param fit (`mmrm`)\cr the fitted MMRM.
117		#' @param visit_level (`string`)\cr the visit level to extract information for.
118		#' @param visit (`string`)\cr the name of the visit variable.
119		#' @param group (`string`)\cr the name of the group variable.
120		#'
121		#' @inheritParams rbmi_mmrm
122		#' @seealso [rbmi_mmrm()]
123		rbmi_mmrm_single_info <- function(fit, visit_level, visit, group, weights) {
124	3x	checkmate::assert_class(fit, "mmrm")
125	3x	checkmate::assert_string(visit_level)
126	3x	checkmate::assert_string(visit)
127	3x	checkmate::assert_string(group)
128
129	3x	data <- mmrm::component(fit, "full_frame")
130	3x	checkmate::assert_factor(data[[group]])
131	3x	grp_levels <- levels(data[[group]])
132
133	3x	visit_at_level <- stats::setNames(list(visit_level), visit)
134	3x	em_res <- emmeans::emmeans(fit, group, by = visit, at = visit_at_level, weights = weights)
135	3x	em_df <- as.data.frame(em_res)
136
137	3x	all_lsm <- lapply(grp_levels, function(x) {
138	9x	this_df <- em_df[em_df[[group]] == x, ]
139	9x	with(this_df, list(est = emmean, se = SE, df = df))
140		})
141	3x	names(all_lsm) <- paste0("lsm_", grp_levels)
142
143	3x	var_est <- mmrm::VarCorr(fit)[visit_level, visit_level]
144
145	3x	cont_res <- emmeans::contrast(em_res, "trt.vs.ctrl", ref = grp_levels[1])
146	3x	cont_df <- as.data.frame(cont_res)
147
148	3x	all_var <- lapply(grp_levels[-1], function(x) {
149	6x	this_df <- cont_df[cont_df[["contrast"]] == paste(x, "-", grp_levels[1]), ]
150		# Note: This should be revisited here for the `se` - currently we take the SE from the LS means contrast, not
151		# from the variance estimate!
152	6x	with(this_df, list(est = var_est, se = SE, df = df))
153		})
154	3x	names(all_var) <- paste0("var_", grp_levels[-1])
155
156	3x	all_trt <- lapply(grp_levels[-1], function(x) {
157	6x	this_df <- cont_df[cont_df[["contrast"]] == paste(x, "-", grp_levels[1]), ]
158	6x	with(this_df, list(est = estimate, se = SE, df = df))
159		})
160	3x	names(all_trt) <- paste0("trt_", grp_levels[-1])
161
162	3x	c(all_var, all_trt, all_lsm)
163		}

1		s_summarize_desc_j <- function(df, .var, .ref_group, .in_ref_col, control = control_analyze_vars()) {
2	5x	x <- df[[.var]]
3	5x	y1 <- s_summary(x)
4	5x	y2 <- NULL
5
6		# diff in means versus control group, based upon 2 sample t.test
7	5x	y2$mean_diffci <- numeric()
8	5x	if (!is.null(.ref_group) && !.in_ref_col) {
9	3x	x1 <- df[[.var]]
10	3x	x2 <- .ref_group[[.var]]
11
12	3x	x1 <- x1[!is.na(x1)]
13	3x	x2 <- x2[!is.na(x2)]
14
15	3x	if ((length(x1) > 1 && length(x2) > 1)) {
16	3x	ttest_stat <- stats::t.test(x1, x2, conf.level = control$conf_level)
17
18	3x	stat <- ttest_stat[c("estimate", "conf.int")]
19	3x	stat$diff <- stat$estimate[1] - stat$estimate[2]
20	3x	stat <- c(stat$diff, stat$conf.int)
21
22	3x	y2$mean_diffci <- with_label(
23	3x	c(mean_diffci = stat),
24	3x	paste("Difference in Mean + ", f_conf_level(control$conf_level))
25		)
26		} else {
27	!	y2b <- s_summary(.ref_group[[.var]])
28	!	diff <- y1[["mean"]] - y2b[["mean"]]
29	!	stat <- c(diff, NA, NA)
30
31	!	y2$mean_diffci <- with_label(
32	!	c(mean_diffci = stat),
33	!	paste("Difference in Mean + ", f_conf_level(control$conf_level))
34		)
35		}
36		}
37	5x	y <- c(y1, y2)
38
39	5x	return(y)
40		}
41
42		s_aval_chg_col1 <- function(df, .var, denom, .N_col, id, indatavar) {
43		## First column AVAL - show n/N (%)
44	4x	mystat <- "n"
45
46	4x	if (!is.null(indatavar)) {
47	!	df <- subset(df, !is.na(df[[indatavar]]))
48		}
49
50	4x	x <- df[[.var]]
51
52	4x	x_stats <- s_summary(x)
53	4x	x_stats <- x_stats[mystat]
54
55		### Ndenom derivation in case denom = N
56	4x	Ndenom <- .N_col
57	4x	if (denom == "N") {
58		### as our input dataset has ensured we have unique subjects we can just use the length of x here still safer
59		### to use id variable
60	4x	nsub <- length(unique(df[[id]]))
61	4x	Ndenom <- nsub
62		}
63
64	4x	count_denom_frac <- c(x_stats$n, Ndenom, x_stats$n / Ndenom)
65	4x	names(count_denom_frac) <- c("n", "N", "fraction")
66
67	4x	count_frac <- count_denom_frac[c("n", "fraction")]
68	4x	count <- count_denom_frac[c("n")]
69
70	4x	y <- list()
71	4x	y$count_denom_frac <- count_denom_frac
72	4x	y$count_frac <- count_frac
73	4x	y$count <- count
74
75	4x	return(y)
76		}
77
78		s_aval_chg_col23_diff <- function(
79		df,
80		.var,
81		.df_row,
82		.ref_group,
83		.in_ref_col,
84		ancova,
85		interaction_y,
86		interaction_item,
87		conf_level,
88		variables,
89		trt_var,
90		ctrl_grp,
91		cur_param,
92		cur_lvl
93		) {
94	10x	.df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
95	10x	df <- subset(df, !is.na(df[[.var]]))
96	10x	.ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))
97
98	10x	if (nrow(.df_row) == 0) {
99		#### this is only when input row no non-missing records in any of the columns expected to occur for baseline
100		#### timepoint for analysis variable change only here we want a blank cell, not a cell with all NA's NULL is
101		#### generating a blank cell
102	!	x_stats <- NULL
103	!	mystat1 <- c("mean_ci_3d", "mean_diffci")
104	10x	} else if (!ancova) {
105	5x	mystat1 <- c("mean_ci_3d", "mean_diffci")
106
107	5x	control <- control_analyze_vars()
108	5x	control$conf_level <- conf_level
109	5x	x_stats <- s_summarize_desc_j(
110	5x	df = df,
111	5x	.var = .var,
112	5x	.ref_group = .ref_group,
113	5x	.in_ref_col = .in_ref_col,
114	5x	control = control
115		)
116		} else {
117	5x	mystat1 <- c("lsmean_ci", "lsmean_diffci")
118
119		### sparse data problems with underlying ancova function 1/ if nrow(.df_row) = 0 NULL (blank columns)
120
121		### 2/ if nrow(df) = 0 no ancova - lsmean and lsmean diff should be na
122
123		### 3/ if nrow(df) > 0, & nrow(.ref_group) = 0 ancova for ls mean only, NULL .ref_group -- lsmean diff should
124		### be na
125
126		### 4/ if nrow(df) > 0, & nrow(.ref_group) > 0 and at least one group with 0 data update levels in
127		### .df_row/df/.ref_group to avoid problems for contrast
128
129		#### by making updates to .df_row/df/.ref_group, situation 3 and 4 could be used together with general case
130
131	5x	.df_row_trtlevels <- unique(.df_row[[trt_var]])
132
133	5x	if (NROW(.df_row_trtlevels) == 0) {
134		### No data at all
135	!	x_stats <- NULL
136	5x	} else if (NROW(df) == 0 \|\| NROW(.df_row_trtlevels) == 1) {
137		### current column no data/less than 2 treatment levels
138
139	!	x_stats <- list()
140	!	x_stats[[mystat1[1]]] <- rep(NA, 3)
141	!	x_stats[[mystat1[2]]] <- rep(NA, 3)
142		} else {
143		### ancova situation, and some updates to prevent problems with sparse data
144	5x	if ((!ctrl_grp %in% .df_row_trtlevels)) {
145		# LS means for current group can be estimated from model, but not difference in LS means set .ref_group
146		# to NULL to proceed with s_summarize_ancova_j function update to underlying s_ancova_j to cover NULL
147		# ref_group in call
148	!	.ref_group <- NULL
149		}
150	5x	if (NROW(.df_row_trtlevels) < length(levels(.df_row[[trt_var]]))) {
151		# missing levels need to be removed from the factor, in order to have the correct estimates, and avoid
152		# errors with underlying tern:::s_ancova function
153	!	.df_row[[trt_var]] <- droplevels(.df_row[[trt_var]])
154	!	df[[trt_var]] <- factor(as.character(df[[trt_var]]), levels = levels(.df_row[[trt_var]]))
155	!	.ref_group[[trt_var]] <- factor(as.character(.ref_group[[trt_var]]), levels = levels(.df_row[[trt_var]]))
156		}
157
158	5x	x_stats <- s_summarize_ancova_j(
159	5x	df = df,
160	5x	.var = .var,
161	5x	.ref_group = .ref_group,
162	5x	.in_ref_col = .in_ref_col,
163	5x	.df_row = .df_row,
164	5x	conf_level = conf_level,
165	5x	interaction_y = interaction_y,
166	5x	interaction_item = interaction_item,
167	5x	variables = variables
168		)
169		}
170		}
171
172	10x	y <- list(mean_ci_3d = x_stats[[mystat1[1]]], meandiff_ci_3d = x_stats[[mystat1[2]]])
173	10x	return(y)
174		}
175
176
177		xxd_to_xx <- function(str, d = 0) {
178	10x	checkmate::assert_integerish(d, null.ok = TRUE)
179	10x	if (checkmate::test_list(str, null.ok = FALSE)) {
180	!	checkmate::assert_list(str, null.ok = FALSE)
181		# Or it may be a vector of characters
182		} else {
183	10x	checkmate::assert_character(str, null.ok = FALSE)
184		}
185
186	10x	nmstr <- names(str)
187
188	10x	if (any(grepl("xx.d", str, fixed = TRUE))) {
189	10x	checkmate::assert_integerish(d)
190	10x	str <- gsub("xx.d", paste0("xx.", strrep("x", times = d)), str, fixed = TRUE)
191		}
192	10x	str <- stats::setNames(str, nmstr)
193	10x	return(str)
194		}
195
196		format_xxd <- function(str, d = 0, .df_row, formatting_fun = NULL) {
197		# Handling of data precision
198	10x	if (!is.numeric(d)) {
199	!	if (is.character(d) && length(d) == 1) {
200		# check if d is a variable name available in .df_row
201	!	if (d %in% names(.df_row)) {
202	!	d <- max(.df_row[[d]], na.rm = TRUE)
203		} else {
204	!	message(paste("precision has been reset to d = 0, as variable", d, "not present on input"))
205	!	d <- 0
206		}
207		}
208		}
209		# convert xxd type of string to xx
210	10x	fmt <- xxd_to_xx(str = str, d = d)
211
212	10x	if (!is.null(formatting_fun)) {
213	10x	fmt <- formatting_fun(fmt)
214		}
215
216	10x	return(fmt)
217		}
218
219		#' @name a_summarize_aval_chg_diff_j
220		#'
221		#' @title Analysis function 3-column presentation
222		#'
223		#' @inherit proposal_argument_convention
224		#'
225		#' @description Analysis functions to produce a 1-row summary presented in
226		#' a 3-column layout in the columns: column 1: N, column 2: Value, column 3: change\cr
227		#' In the difference columns, only 1 column will be presented : difference + CI\cr
228		#' When ancova = `TRUE`, the presented statistics will be based on ANCOVA method (`s_summarize_ancova_j`).\cr
229		#' mean and ci (both for Value (column 2) and Chg (column 3)) using statistic `lsmean_ci`\cr
230		#' mean and ci for the difference column are based on same ANCOVA model using statistic `lsmean_diffci`\cr
231		#' When ancova = `FALSE`, descriptive statistics will be used instead.\cr
232		#' In the difference column, the 2-sample t-test will be used.
233		#'
234		#' @details See Description
235		#'
236		#' @inheritParams proposal_argument_convention
237		#' @param denom (`string`)\cr choice of denominator for proportions. Options are:
238		#' * `N`: number of records in this column/row split.
239		#' \cr There is no check in place that the current split only has one record per subject.
240		#' Users should be careful with this.
241		#' * `.N_col`: number of records in this column intersection (based on alt_counts_df dataset)
242		#' \cr (when alt_counts_df is a single record per subjects, this will match number of subjects)
243		#'
244		#' @param d (default = 1) \cr choice of Decimal precision.
245		#' Note that one extra precision will be added, as means are presented.
246		#' \cr Options are:
247		#' * numerical(1)
248		#' * variable name containing information on the precision, this variable
249		#' should be available on input dataset. The content of this variable should
250		#' then be an integer.
251		#'
252		#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
253		#' If TRUE Ancova methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
254		#' @param comp_btw_group (`logical`)\cr If TRUE,
255		#' \cr When ancova = FALSE, the estimate of between group difference (on CHG)
256		#' will be based upon a two-sample t-test. \cr
257		#' \cr When ancova = TRUE, the same ancova model will be used for the estimate of between group difference (on CHG).
258		#'
259		#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
260		#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
261		#' @param conf_level (`proportion`)\cr Confidence level of the interval
262		#' @param variables (named list of strings)\cr
263		#' list of additional analysis variables, with expected elements:
264		#' * arm (string)\cr
265		#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
266		#' Specifically, the first level of arm variable is taken as the reference group.
267		#' * covariates (character)\cr
268		#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
269		#'
270		#'
271		#' @param format_na_str (`string`)\cr
272		#'
273		#' @param indatavar (`string`)\cr If not null, variable name to extra subset
274		#' incoming df to non-missing values of this variable.
275		#' @param multivars (`string(3)`)\cr Variables names to use in 3-col layout.
276		#'
277		#' @param .stats (named `list`)\cr column statistics to select for the table.
278		#' The following column names are to be used: `col1`, `col23`, `coldiff`.\cr
279		#' For `col1`, the following stats can be specified.\cr
280		#' For `col23`, only `mean_ci_3d` is available. When ancova=`TRUE` these are LS Means, otherwise, arithmetic means.\cr
281		#' For `coldiff`, only `meandiff_ci_3d` is available. When ancova=`TRUE` these
282		#' are LS difference in means, otherwise, difference in means based upon 2-sample t-test.\cr
283		#' @param .formats (named `list`)\cr formats for the column statistics. `xx.d` style formats can be used.
284		#' @param .formats_fun (named `list`)\cr formatting functions for the column
285		#' statistics, to be applied after the conversion of `xx.d` style to the
286		#' appropriate precision.
287		#'
288		#' @rdname a_summarize_aval_chg_diff_j
289		#' @return A function that can be used in an analyze function call
290		#' @export
291		#'
292		#'
293		#' @examples
294		#'
295		#' library(dplyr)
296		#'
297		#' ADEG <- data.frame(
298		#' STUDYID = c(
299		#' 'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY',
300		#' 'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY', 'DUMMY'
301		#' ),
302		#' USUBJID = c(
303		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
304		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
305		#' ),
306		#' TRT01A = c(
307		#' 'ARMA', 'ARMA', 'ARMA', 'ARMA', 'ARMA', 'Placebo',
308		#' 'Placebo', 'Placebo', 'ARMA', 'ARMA'
309		#' ),
310		#' PARAM = c('BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP', 'BP'),
311		#' AVISIT = c(
312		#' 'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1',
313		#' 'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1', 'Visit 1'
314		#' ),
315		#' AVAL = c(56, 78, 67, 87, 88, 93, 39, 87, 65, 55),
316		#' CHG = c(2, 3, -1, 9, -2, 0, 6, -2, 5, 2)
317		#' )
318		#'
319		#' ADEG <- ADEG \|>
320		#' mutate(
321		#' TRT01A = as.factor(TRT01A),
322		#' STUDYID = as.factor(STUDYID)
323		#' )
324		#'
325		#' ADEG$colspan_trt <- factor(ifelse(ADEG$TRT01A == 'Placebo', ' ', 'Active Study Agent'),
326		#' levels = c('Active Study Agent', ' ')
327		#' )
328		#' ADEG$rrisk_header <- 'Risk Difference (%) (95% CI)'
329		#' ADEG$rrisk_label <- paste(ADEG$TRT01A, paste('vs', 'Placebo'))
330		#'
331		#' colspan_trt_map <- create_colspan_map(ADEG,
332		#' non_active_grp = 'Placebo',
333		#' non_active_grp_span_lbl = ' ',
334		#' active_grp_span_lbl = 'Active Study Agent',
335		#' colspan_var = 'colspan_trt',
336		#' trt_var = 'TRT01A'
337		#' )
338		#' ref_path <- c('colspan_trt', ' ', 'TRT01A', 'Placebo')
339		#'
340		#' lyt <- basic_table() \|>
341		#' ### first columns
342		#' split_cols_by(
343		#' 'colspan_trt',
344		#' split_fun = trim_levels_to_map(map = colspan_trt_map)
345		#' ) \|>
346		#' split_cols_by('TRT01A') \|>
347		#' split_rows_by(
348		#' 'PARAM',
349		#' label_pos = 'topleft',
350		#' split_label = 'Blood Pressure',
351		#' section_div = ' ',
352		#' split_fun = drop_split_levels
353		#' ) \|>
354		#' split_rows_by(
355		#' 'AVISIT',
356		#' label_pos = 'topleft',
357		#' split_label = 'Study Visit',
358		#' split_fun = drop_split_levels,
359		#' child_labels = 'hidden'
360		#' ) \|>
361		#' ## set up a 3 column split
362		#' split_cols_by_multivar(
363		#' c('AVAL', 'AVAL', 'CHG'),
364		#' varlabels = c('n/N (%)', 'Mean (CI)', 'CFB (CI)')
365		#' ) \|>
366		#' split_cols_by('rrisk_header', nested = FALSE) \|>
367		#' split_cols_by(
368		#' 'TRT01A',
369		#' split_fun = remove_split_levels('Placebo'),
370		#' labels_var = 'rrisk_label'
371		#' ) \|>
372		#' ### difference columns : just 1 column & analysis needs to be done on change
373		#' split_cols_by_multivar(c('CHG'), varlabels = c(' ')) \|>
374		#' # the variable passed here in analyze is not used (STUDYID),
375		#' # it is a dummy var passing, the function a_summarize_aval_chg_diff_j
376		#' # grabs the required vars from cols_by_multivar calls
377		#' analyze('STUDYID',
378		#' afun = a_summarize_aval_chg_diff_j,
379		#' extra_args = list(
380		#' format_na_str = '-', d = 0,
381		#' ref_path = ref_path, variables = list(arm = 'TRT01A', covariates = NULL)
382		#' )
383		#' )
384		#'
385		#' result <- build_table(lyt, ADEG)
386		#'
387		#' result
388		#' @seealso s_summarize_ancova_j
389		#' @family Inclusion of ANCOVA Functions
390		a_summarize_aval_chg_diff_j <- function(
391		df,
392		.df_row,
393		.spl_context,
394		ancova = FALSE,
395		comp_btw_group = TRUE,
396		ref_path = NULL,
397		.N_col,
398		denom = c("N", ".N_col"),
399		indatavar = NULL,
400		d = 0,
401		id = "USUBJID",
402		interaction_y = FALSE,
403		interaction_item = NULL,
404		conf_level = 0.95,
405		variables = list(arm = "TRT01A", covariates = NULL),
406		format_na_str = "",
407		.stats = list(col1 = "count_denom_frac", col23 = "mean_ci_3d", coldiff = "meandiff_ci_3d"),
408		.formats = list(col1 = NULL, col23 = "xx.dx (xx.dx, xx.dx)", coldiff = "xx.dx (xx.dx, xx.dx)"),
409		.formats_fun = list(col1 = jjcsformat_count_denom_fraction, col23 = jjcsformat_xx, coldiff = jjcsformat_xx),
410		multivars = c("AVAL", "AVAL", "CHG")
411		) {
412	14x	denom <- match.arg(denom)
413
414	14x	if (comp_btw_group && is.null(ref_path)) {
415	!	stop("ref_path cannot be NULL, please specify it. See ?get_ref_info for details.")
416		}
417
418	14x	if (!(length(multivars) == 3)) {
419	!	stop("argument multivars must be of length 3.")
420		}
421
422	14x	if (!(all(multivars %in% names(df)))) {
423	!	stop("all variables specified in multivars must be available on input dataset df.")
424		}
425
426	14x	if (multivars[1] == multivars[2]) {
427	14x	multivars[2] <- paste0(multivars[2], "._[[2]]_.")
428		}
429
430		if (
431	14x	!is.list(.stats) \|\|
432	14x	!all(c("col1", "col23", "coldiff") %in% names(.stats)) \|\|
433	14x	!is.list(.formats) \|\|
434	14x	!all(c("col1", "col23", "coldiff") %in% names(.formats)) \|\|
435	14x	!is.list(.formats_fun) \|\|
436	14x	!all(c("col1", "col23", "coldiff") %in% names(.formats_fun))
437		) {
438	!	stop(paste(
439	!	"Issue a_summarize_aval_chg_diff_j \n.stats/.formats/.formats_fun must",
440	!	"be a list with names c(\"col1\", \"col23\", \"coldiff\")."
441		))
442		}
443
444	14x	row_vars <- .spl_context$split
445	14x	row_val <- .spl_context$cur_col_split_val
446
447	14x	col_split <- .spl_context$cur_col_split
448
449		## treatment group value/variable KEY assumption : treatment variable is the last split_col prior to
450		## split_cols_by_multivar
451	14x	colvars <- col_split[[NROW(.spl_context)]]
452	14x	colvars_multivars <- which(colvars == "multivars")
453	14x	if (identical(colvars_multivars, integer(0))) {
454	!	stop("Layout must at least contain a split_cols_by_multivar call.")
455		}
456	14x	if (colvars_multivars == 1) {
457	!	stop("Layout must at least contain a split_cols_by prior to split_cols_by_multivar call.")
458		}
459		## KEY assumption : treatment variable is the last split_col prior to split_cols_by_multivar
460	14x	trt_var <- .spl_context$cur_col_split[[NROW(.spl_context)]][colvars_multivars - 1]
461	14x	trt_val <- .spl_context$cur_col_split_val[[NROW(.spl_context)]][colvars_multivars - 1]
462
463	14x	mysplitlevel <- length(.spl_context$split)
464	14x	cur_lvl <- .spl_context$value[[mysplitlevel]]
465	14x	cur_col_id <- .spl_context$cur_col_id[[mysplitlevel]]
466
467	14x	cur_param <- .spl_context$value[[mysplitlevel - 1]]
468
469	14x	indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)
470
471		# Early return if we're not comparing between groups but we're in a difference column
472	14x	if (!comp_btw_group && indiffcol) {
473	!	return(rcell(NULL, format = NULL, label = cur_lvl, format_na_str = format_na_str))
474		}
475
476		## variable that is analyzed
477	14x	last_val <- utils::tail(.spl_context$cur_col_split_val[[NROW(.spl_context)]], 1)
478
479		# as AVAL will be utilized twice, the second call results in last_val == 'AVAL._[[2]]_.' take the first part of it
480		# in flast_val (will become AVAL) flast_val <- stringr::str_split_1(last_val, pattern = '._')[1]
481	14x	flast_val <- unlist(strsplit(last_val, "._"))[1]
482
483	14x	x_stats <- NULL
484	14x	fmt_d <- NULL
485
486	14x	.in_ref_col <- FALSE
487	14x	.ref_group <- NULL
488	14x	if (comp_btw_group) {
489	14x	trt_var_refspec <- utils::tail(ref_path, n = 2)[1]
490	14x	checkmate::assert_true(identical(trt_var, trt_var_refspec))
491		# ctrl_grp
492	14x	ctrl_grp <- utils::tail(ref_path, n = 1)
493
494		### check that ctrl_grp is a level of the treatment variable, in case riskdiff is requested
495	14x	if (!ctrl_grp %in% levels(df[[trt_var]])) {
496	!	stop(paste0(
497	!	"control group specification in ref_path argument (",
498	!	ctrl_grp,
499	!	") is not a level of your treatment group variable (",
500	!	trt_var,
501		")."
502		))
503		}
504
505	6x	if (trt_val == ctrl_grp) .in_ref_col <- TRUE
506
507	14x	.ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]
508		}
509
510	14x	if (last_val == multivars[1] && !indiffcol) {
511	4x	mystat <- .stats[["col1"]]
512	4x	if (is.null(.formats[["col1"]])) {
513	4x	fmt <- .formats_fun[["col1"]]
514		} else {
515	!	fmt <- .formats[["col1"]]
516		}
517
518	4x	x_stats <- s_aval_chg_col1(
519	4x	df = df,
520	4x	.var = flast_val,
521	4x	denom = denom,
522	4x	.N_col = .N_col,
523	4x	id = id,
524	4x	indatavar = indatavar
525		)
526	10x	} else if (last_val %in% multivars[2:3]) {
527	10x	x_stats <- s_aval_chg_col23_diff(
528	10x	df = df,
529	10x	.var = flast_val,
530	10x	.df_row = .df_row,
531	10x	.ref_group = .ref_group,
532	10x	.in_ref_col = .in_ref_col,
533	10x	ancova = ancova,
534	10x	interaction_y = interaction_y,
535	10x	interaction_item = interaction_item,
536	10x	conf_level = conf_level,
537	10x	variables = variables,
538	10x	trt_var = trt_var,
539	10x	ctrl_grp = ctrl_grp,
540	10x	cur_param = cur_param,
541	10x	cur_lvl = cur_lvl
542		)
543
544	10x	if (comp_btw_group && indiffcol) {
545	2x	mystat1 <- "coldiff"
546		} else {
547	8x	mystat1 <- "col23"
548		}
549	10x	mystat <- .stats[[mystat1]]
550
551	10x	fmt_d <- .formats[[mystat1]]
552	10x	formatting_fun <- .formats_fun[[mystat1]]
553
554	10x	fmt <- format_xxd(fmt_d, d = d, .df_row = .df_row, formatting_fun = formatting_fun)
555		}
556	14x	x_stats <- x_stats[[mystat]]
557
558		##
559	14x	ret <- rcell(x_stats, format = fmt, label = cur_lvl, format_na_str = format_na_str)
560
561	14x	return(ret)
562		}

1		#' Odds ratio estimation
2		#'
3		#' @description `r lifecycle::badge('stable')`
4		#'
5		#' @param method (`string`)\cr whether to use the correct (`'exact'`) calculation in the conditional likelihood or one
6		#' of the approximations, or the CMH method. See [survival::clogit()] for details.
7		#'
8		#' @param df (`data.frame`)\cr input data frame.
9		#' @param .var (`string`)\cr name of the response variable.
10		#' @param .df_row (`data.frame`)\cr data frame containing all rows.
11		#' @param ref_path (`character`)\cr path to the reference group.
12		#' @param .spl_context (`environment`)\cr split context environment.
13		#' @param ... Additional arguments passed to the statistics function.
14		#' @param .stats (`character`)\cr statistics to calculate.
15		#' @param .formats (`list`)\cr formats for the statistics.
16		#' @param .labels (`list`)\cr labels for the statistics.
17		#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
18		#' @param .ref_group (`data.frame`)\cr reference group data frame.
19		#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
20		#' @param variables (`list`)\cr list with arm and strata variable names.
21		#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
22		#' @param groups_list (`list`)\cr list of groups for combination.
23		#'
24		#' @note
25		#' The `a_odds_ratio_j()` and `s_odds_ratio_j()` functions have the `_j` suffix to distinguish them
26		#' from [tern::a_odds_ratio()] and [tern::s_odds_ratio()], respectively.
27		#' These functions differ as follows:
28		#'
29		#' * Additional `method = 'cmh'` option is provided to calculate the Cochran-Mantel-Haenszel estimate.
30		#' * The p-value is returned as an additional statistic.
31		#'
32		#' Once these updates are contributed back to `tern`, they can later be replaced by the `tern` versions.
33		#'
34		#' @name odds_ratio
35		#' @order 1
36		NULL
37
38		#' @describeIn odds_ratio Statistics function which estimates the odds ratio
39		#' between a treatment and a control. A `variables` list with `arm` and `strata`
40		#' variable names must be passed if a stratified analysis is required.
41		#'
42		#' @param na_if_no_events (`flag`)\cr whether the point estimate should be `NA` if there
43		#' are no events in one arm. The p-value and confidence interval will still be computed.
44		#'
45		#' @return
46		#' * `s_odds_ratio_j()` returns a named list with the statistics `or_ci`
47		#' (containing `est`, `lcl`, and `ucl`), `pval` and `n_tot`.
48		#'
49		#' @examples
50		#' # Unstratified analysis.
51		#' s_odds_ratio_j(
52		#' df = subset(dta, grp == 'A'),
53		#' .var = 'rsp',
54		#' .ref_group = subset(dta, grp == 'B'),
55		#' .in_ref_col = FALSE,
56		#' .df_row = dta
57		#' )
58		#'
59		#' # Stratified analysis.
60		#' s_odds_ratio_j(
61		#' df = subset(dta, grp == 'A'),
62		#' .var = 'rsp',
63		#' .ref_group = subset(dta, grp == 'B'),
64		#' .in_ref_col = FALSE,
65		#' .df_row = dta,
66		#' variables = list(arm = 'grp', strata = 'strata')
67		#' )
68		#'
69		#' # Stratified analysis with CMH.
70		#' s_odds_ratio_j(
71		#' df = subset(dta, grp == 'A'),
72		#' method = 'cmh',
73		#' .var = 'rsp',
74		#' .ref_group = subset(dta, grp == 'B'),
75		#' .in_ref_col = FALSE,
76		#' .df_row = dta,
77		#' variables = list(arm = 'grp', strata = c('strata'))
78		#' )
79		#' @export
80		s_odds_ratio_j <- function(
81		df,
82		.var,
83		.ref_group,
84		.in_ref_col,
85		.df_row,
86		variables = list(arm = NULL, strata = NULL),
87		conf_level = 0.95,
88		groups_list = NULL,
89		na_if_no_events = TRUE,
90		method = c("exact", "approximate", "efron", "breslow", "cmh")
91		) {
92	17x	checkmate::assert_flag(na_if_no_events)
93		# New: pval here
94	17x	y <- list(or_ci = list(), n_tot = list(), pval = list())
95	17x	method <- match.arg(method)
96	17x	one_group_empty <- nrow(df) == 0 \|\| nrow(.ref_group) == 0
97
98	17x	if (!.in_ref_col) {
99	15x	(assert_proportion_value)(conf_level)
100	15x	assert_df_with_variables(df, list(rsp = .var))
101	15x	assert_df_with_variables(.ref_group, list(rsp = .var))
102
103	15x	if (one_group_empty) {
104	1x	y <- list(or_ci = c(est = NA_real_, lcl = 0, ucl = Inf), n_tot = c(n_tot = nrow(df) + nrow(.ref_group)), pval = 1)
105	14x	} else if (is.null(variables$strata)) {
106	6x	data <- data.frame(
107	6x	rsp = c(.ref_group[[.var]], df[[.var]]),
108	6x	grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))
109		)
110	6x	y <- or_glm(data, conf_level = conf_level)
111		} else {
112	8x	assert_df_with_variables(.df_row, c(list(rsp = .var), variables))
113	8x	checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow", "cmh"), empty.ok = FALSE)
114		# The group variable prepared for stratified analysis must be synchronized with the combination groups
115		# definition.
116	8x	if (is.null(groups_list)) {
117	8x	ref_grp <- as.character(unique(.ref_group[[variables$arm]]))
118	8x	trt_grp <- as.character(unique(df[[variables$arm]]))
119	8x	grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)
120		} else {
121		# If more than one level in reference col.
122	!	reference <- as.character(unique(.ref_group[[variables$arm]]))
123	!	grp_ref_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(reference %in% x))
124	!	ref_grp <- names(groups_list)[grp_ref_flag]
125
126		# If more than one level in treatment col.
127	!	treatment <- as.character(unique(df[[variables$arm]]))
128	!	grp_trt_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(treatment %in% x))
129	!	trt_grp <- names(groups_list)[grp_trt_flag]
130
131	!	grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)
132	!	grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)
133		}
134
135		# New: CMH method
136	8x	if (method == "cmh") {
137	7x	data <- data.frame(
138	7x	rsp = c(.ref_group[[.var]], df[[.var]]),
139	7x	grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref")),
140	7x	strata = interaction(rbind(.ref_group[variables$strata], df[variables$strata]))
141		)
142
143	7x	y <- or_cmh(data, conf_level = conf_level)
144		} else {
145		# The reference level in `grp` must be the same as in the `rtables` column split.
146	1x	data <- data.frame(rsp = .df_row[[.var]], grp = grp, strata = interaction(.df_row[variables$strata]))
147
148	1x	y_all <- or_clogit(data, conf_level = conf_level, method = method)
149	1x	checkmate::assert_string(trt_grp)
150		# New: pval here
151	1x	checkmate::assert_subset(trt_grp, names(y_all$or_ci_pvals))
152	1x	y_or_ci_pval <- y_all$or_ci_pvals[[trt_grp]]
153	1x	y$or_ci <- y_or_ci_pval[c("est", "lcl", "ucl")]
154	1x	y$n_tot <- y_all$n_tot
155	1x	y$pval <- y_or_ci_pval["pval"]
156		}
157		}
158
159	15x	one_group_no_events <- (sum(.ref_group[[.var]]) == 0) \|\| (sum(df[[.var]]) == 0)
160	15x	if (na_if_no_events && one_group_no_events) {
161	4x	y$or_ci[["est"]] <- NA_real_
162		}
163
164	15x	na_because_sparse <- one_group_empty \|\| (na_if_no_events && one_group_no_events)
165	15x	if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && !na_because_sparse && method != "approximate") {
166	!	warning(
167	!	"Unable to compute the odds ratio estimate. Please try re-running the function with ",
168	!	"parameter `method` set to \"approximate\"."
169		)
170		}
171		}
172
173	17x	y$or_ci <- with_label(x = y$or_ci, label = paste0("Odds Ratio (", 100 * conf_level, "% CI)"))
174
175		# New: pval here
176	17x	y$pval <- unname(y$pval)
177
178	17x	y
179		}
180
181		#' @describeIn odds_ratio Formatted analysis function which is used as `afun`. Note that the
182		#' junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
183		#'
184		#' @return
185		#' * `a_odds_ratio_j()` returns the corresponding list with formatted [rtables::CellValue()].
186		#'
187		#' @examples
188		#' set.seed(12)
189		#' dta <- data.frame(
190		#' rsp = sample(c(TRUE, FALSE), 100, TRUE),
191		#' grp = factor(rep(c('A', 'B'), each = 50), levels = c('A', 'B')),
192		#' strata = factor(sample(c('C', 'D'), 100, TRUE))
193		#' )
194		#'
195		#' a_odds_ratio_j(
196		#' df = subset(dta, grp == 'A'),
197		#' .var = 'rsp',
198		#' ref_path = c('grp', 'B'),
199		#' .spl_context = data.frame(
200		#' cur_col_split = I(list('grp')),
201		#' cur_col_split_val = I(list(c(grp = 'A'))),
202		#' full_parent_df = I(list(dta))
203		#' ),
204		#' .df_row = dta
205		#' )
206		#'
207		#'
208		#' l <- basic_table() \|>
209		#' split_cols_by(var = 'grp') \|>
210		#' analyze(
211		#' 'rsp',
212		#' afun = a_odds_ratio_j,
213		#' show_labels = 'hidden',
214		#' extra_args = list(
215		#' ref_path = c('grp', 'B'),
216		#' .stats = c('or_ci', 'pval')
217		#' )
218		#' )
219		#'
220		#' build_table(l, df = dta)
221		#'
222		#' l2 <- basic_table() \|>
223		#' split_cols_by(var = 'grp') \|>
224		#' analyze(
225		#' 'rsp',
226		#' afun = a_odds_ratio_j,
227		#' show_labels = 'hidden',
228		#' extra_args = list(
229		#' variables = list(arm = 'grp', strata = 'strata'),
230		#' method = 'cmh',
231		#' ref_path = c('grp', 'A'),
232		#' .stats = c('or_ci', 'pval')
233		#' )
234		#' )
235		#'
236		#' build_table(l2, df = dta)
237		#' @export
238		#' @order 2
239		a_odds_ratio_j <- function(
240		df,
241		.var,
242		.df_row,
243		ref_path,
244		.spl_context,
245		...,
246		.stats = NULL,
247		.formats = NULL,
248		.labels = NULL,
249		.indent_mods = NULL
250		) {
251		# Check for additional parameters to the statistics function
252	4x	dots_extra_args <- list(...)
253
254		# Only support default stats, not custom stats
255	4x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
256
257		# Obtain reference column information
258	4x	ref <- get_ref_info(ref_path, .spl_context)
259
260		# Apply statistics function
261	4x	x_stats <- .apply_stat_functions(
262	4x	default_stat_fnc = s_odds_ratio_j,
263	4x	custom_stat_fnc_list = NULL,
264	4x	args_list = c(
265	4x	df = list(df),
266	4x	.var = .var,
267	4x	.df_row = list(.df_row),
268	4x	.ref_group = list(ref$ref_group),
269	4x	.in_ref_col = ref$in_ref_col,
270	4x	dots_extra_args
271		)
272		)
273
274		# Format according to specifications
275	4x	format_stats(
276	4x	x_stats,
277	4x	method_groups = "odds_ratio",
278	4x	stats_in = .stats,
279	4x	formats_in = .formats,
280	4x	labels_in = .labels,
281	4x	indents_in = .indent_mods
282		)
283		}
284
285		#' Helper functions for odds ratio estimation
286		#'
287		#' @description `r lifecycle::badge('stable')`
288		#'
289		#' Functions to calculate odds ratios in [s_odds_ratio_j()].
290		#'
291		#' @inheritParams odds_ratio
292		#' @inheritParams proposal_argument_convention
293		#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally
294		#' `strata` for [or_clogit()].
295		#' # New: pval here
296		#' @return A named `list` of elements `or_ci`, `n_tot` and `pval`.
297		#'
298		#' @seealso [odds_ratio]
299		#'
300		#' @name h_odds_ratio
301		NULL
302
303		#' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be
304		#' exactly 2 groups in `data` as specified by the `grp` variable.
305		#'
306		#' @examples
307		#' # Data with 2 groups.
308		#' data <- data.frame(
309		#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),
310		#' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],
311		#' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],
312		#' stringsAsFactors = TRUE
313		#' )
314		#'
315		#' # Odds ratio based on glm.
316		#' or_glm(data, conf_level = 0.95)
317		#'
318		#' @export
319		or_glm <- function(data, conf_level) {
320	7x	checkmate::assert_logical(data$rsp)
321	7x	(assert_proportion_value)(conf_level)
322	7x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
323	7x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
324
325	7x	data$grp <- as_factor_keep_attributes(data$grp)
326	7x	assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
327	7x	formula <- stats::as.formula("rsp ~ grp")
328	7x	model_fit <- stats::glm(formula = formula, data = data, family = stats::binomial(link = "logit"))
329
330		# Note that here we need to discard the intercept.
331	7x	or <- exp(stats::coef(model_fit)[-1])
332	7x	or_ci <- exp(stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE])
333
334	7x	values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
335	7x	n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")
336
337		# New: pval here
338	7x	pval <- summary(model_fit)$coef[-1, "Pr(>\|z\|)"]
339
340	7x	list(or_ci = values, n_tot = n_tot, pval = pval)
341		}
342
343		#' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for
344		#' the whole data set including all groups, since the results are not the same as when doing
345		#' pairwise comparisons between the groups.
346		#'
347		#' @examples
348		#' # Data with 3 groups.
349		#' data <- data.frame(
350		#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),
351		#' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],
352		#' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],
353		#' stringsAsFactors = TRUE
354		#' )
355		#'
356		#'
357		#' # Odds ratio based on stratified estimation by conditional logistic regression.
358		#' or_clogit(data, conf_level = 0.95)
359		#'
360		#' @export
361		or_clogit <- function(data, conf_level, method = "exact") {
362	1x	checkmate::assert_logical(data$rsp)
363	1x	(assert_proportion_value)(conf_level)
364	1x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))
365	1x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
366	1x	checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
367	1x	checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
368
369	1x	data$grp <- as_factor_keep_attributes(data$grp)
370	1x	data$strata <- as_factor_keep_attributes(data$strata)
371
372		# Deviation from convention: `survival::strata` must be simply `strata`.
373	1x	strata <- survival::strata
374	1x	formula <- stats::as.formula("rsp ~ grp + strata(strata)")
375	1x	model_fit <- clogit_with_tryCatch(
376	1x	formula = formula,
377	1x	data = data,
378	1x	method = method
379		)
380
381		# New: pval here
382
383		# Create a list with one set of OR estimates, CI and p-value per coefficient, i.e. comparison of one group vs. the
384		# reference group.
385	1x	coef_est <- stats::coef(model_fit)
386	1x	ci_est <- stats::confint(model_fit, level = conf_level)
387	1x	pvals <- summary(model_fit)$coef[, "Pr(>\|z\|)", drop = FALSE]
388	1x	or_ci_pvals <- list()
389	1x	for (coef_name in names(coef_est)) {
390	1x	grp_name <- gsub("^grp", "", x = coef_name)
391	1x	or_ci_pvals[[grp_name]] <- stats::setNames(
392	1x	object = c(exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), pvals[coef_name, 1]),
393	1x	nm = c("est", "lcl", "ucl", "pval")
394		)
395		}
396	1x	list(or_ci_pvals = or_ci_pvals, n_tot = c(n_tot = model_fit$n))
397		}
398
399		#' @describeIn h_odds_ratio Estimates the odds ratio based on CMH. Note that there must be
400		#' exactly 2 groups in `data` as specified by the `grp` variable.
401		#'
402		#' @examples
403		#' # Data with 2 groups.
404		#' set.seed(123)
405		#' data <- data.frame(
406		#' rsp = as.logical(rbinom(n = 40, size = 1, prob = 0.5)),
407		#' grp = letters[sample(1:2, size = 40, replace = TRUE)],
408		#' strata = LETTERS[sample(1:2, size = 40, replace = TRUE)],
409		#' stringsAsFactors = TRUE
410		#' )
411		#'
412		#' # Odds ratio based on CMH.
413		#' or_cmh(data, conf_level = 0.95)
414		#'
415		#' @export
416		or_cmh <- function(data, conf_level) {
417	7x	checkmate::assert_logical(data$rsp)
418	7x	assert_proportion_value(conf_level)
419	7x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
420	7x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
421
422	7x	data$grp <- as_factor_keep_attributes(data$grp)
423	7x	assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
424
425		# first dimension: treatment, control - therefore we reverse the levels order 2nd dimension: TRUE, FALSE 3rd
426		# dimension: levels of strata rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
427	7x	t_tbl <- table(
428	7x	factor(data$grp, levels = rev(levels(data$grp))),
429	7x	factor(data$rsp, levels = c("TRUE", "FALSE")),
430	7x	data$strata
431		)
432
433	7x	trt_ind <- 1
434	7x	ctrl_ind <- 2
435
436	7x	resp_ind <- 1
437	7x	nonresp_ind <- 2
438
439	7x	n1resp <- t_tbl[trt_ind, resp_ind, ]
440	7x	n2resp <- t_tbl[ctrl_ind, resp_ind, ]
441	7x	n1non <- t_tbl[trt_ind, nonresp_ind, ]
442	7x	n2non <- t_tbl[ctrl_ind, nonresp_ind, ]
443		# Example: n2non are the control patient non-responders per stratum.
444
445		# CMH statistic for odds ratio, Treatment over Control
446	7x	use_stratum <- (n1resp + n2resp + n1non + n2non) > 0
447	7x	n1resp <- n1resp[use_stratum]
448	7x	n2resp <- n2resp[use_stratum]
449	7x	n1non <- n1non[use_stratum]
450	7x	n2non <- n2non[use_stratum]
451	7x	n <- n1resp + n2resp + n1non + n2non
452
453	7x	or_num <- sum(n1resp * n2non / n)
454	7x	or_denom <- sum(n1non * n2resp / n)
455	7x	log_or <- log(or_num) - log(or_denom)
456	7x	or <- exp(log_or)
457
458	7x	term1_num <- sum((n1resp + n2non) * n1resp * n2non / n^2)
459	7x	term1_denom <- 2 * (sum(n1resp * n2non / n))^2
460
461	7x	term2_num <- sum(((n1resp + n2non) * n1non * n2resp + (n1non + n2resp) * n1resp * n2non) / n^2)
462	7x	term2_denom <- 2 * (sum(n1resp * n2non / n)) * (sum(n1non * n2resp / n))
463
464	7x	term3_num <- sum((n1non + n2resp) * n1non * n2resp / n^2)
465	7x	term3_denom <- 2 * (sum(n1non * n2resp / n))^2
466
467	7x	var_log_or <- term1_num / term1_denom + term2_num / term2_denom + term3_num / term3_denom
468	7x	se_log_or <- sqrt(var_log_or)
469
470	7x	z <- stats::qnorm((1 + conf_level) / 2)
471	7x	log_rel_or <- log_or + c(-1, +1) * z * se_log_or
472	7x	ci <- exp(log_rel_or)
473	7x	or_ci <- stats::setNames(c(or, ci), c("est", "lcl", "ucl"))
474
475	7x	pval <- stats::mantelhaen.test(t_tbl, correct = FALSE)$p.value
476
477	7x	n_tot <- stats::setNames(sum(n), "n_tot")
478
479	7x	list(or_ci = or_ci, n_tot = n_tot, pval = pval)
480		}

1		#' Survival time analysis
2		#'
3		#' @description `r lifecycle::badge('stable')`
4		#'
5		#' The analyze function [kaplan_meier()] creates a layout element to analyze
6		#' survival time by calculating survival time median, 2 quantiles, each with
7		#' their confidence intervals, and range (for all, censored, or event patients).
8		#' The primary analysis variable `vars` is the time variable and the secondary
9		#' analysis variable `is_event` indicates whether or not an event has occurred.
10		#'
11		#' @inheritParams proposal_argument_convention
12		#' @param control (`list`)\cr parameters for comparison details, specified by using the helper function
13		#' [tern::control_surv_time()]. Some possible parameter options are:
14		#' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.
15		#' * `conf_type` (`string`)\cr confidence interval type. Options are 'plain' (default), 'log', or 'log-log',
16		#' see more in [survival::survfit()]. Note option 'none' is not supported.
17		#' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.
18		#'
19		#' @note These functions have been forked from the `tern` package file `survival_time.R`.
20		#' Here we have the additional features:
21		#'
22		#' * Additional statistics `quantiles_lower`, `quantiles_upper`, `range_with_cens_info` are returned.
23		#'
24		#' @examples
25		#' library(dplyr)
26		#' library(tern)
27		#' adtte_f <- tern::tern_ex_adtte \|>
28		#' filter(PARAMCD == "OS") \|>
29		#' mutate(
30		#' AVAL = tern::day2month(AVAL),
31		#' is_event = CNSR == 0
32		#' )
33		#' df <- adtte_f \|> filter(ARMCD == 'ARM A')
34		#' @keywords internal
35		#' @name kaplan_meier
36		#' @order 1
37		NULL
38
39		#' @describeIn kaplan_meier Statistics function which analyzes survival times using Kaplan-Meier.
40		#'
41		#' @return
42		#' * `s_kaplan_meier()` returns the following statistics:
43		#' * `quantiles_lower`: Lower quantile estimate and confidence interval for it.
44		#' * `median_ci_3d`: Median survival time and confidence interval for it.
45		#' * `quantiles_upper`: Upper quantile estimate and confidence interval for it.
46		#' * `range_with_cens_info`: Survival time range with censoring information.
47		#'
48		#' @importFrom survival survfit
49		#'
50		#' @keywords internal
51		s_kaplan_meier <- function(df, .var, is_event, control = control_surv_time()) {
52	10x	checkmate::assert_string(.var)
53	10x	assert_df_with_variables(df, list(tte = .var, is_event = is_event))
54	10x	checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)
55	10x	checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)
56
57	10x	conf_type <- control$conf_type
58	10x	conf_level <- control$conf_level
59
60	10x	checkmate::assert_true(control$quantiles[1] < 0.5)
61	10x	checkmate::assert_true(control$quantiles[2] > 0.5)
62	10x	quantiles <- c(control$quantiles[1], 0.5, control$quantiles[2])
63
64	10x	formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
65	10x	srv_fit <- survival::survfit(formula = formula, data = df, conf.int = conf_level, conf.type = conf_type)
66	10x	srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)
67	10x	quantiles_lower <- vapply(srv_qt_tab, "[", 1, FUN.VALUE = numeric(1))
68	10x	median_ci <- vapply(srv_qt_tab, "[", 2, FUN.VALUE = numeric(1))
69	10x	quantiles_upper <- vapply(srv_qt_tab, "[", 3, FUN.VALUE = numeric(1))
70	10x	range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)
71	10x	range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)
72	10x	range <- range_noinf(df[[.var]], na.rm = TRUE)
73	10x	lower_censored <- as.numeric(range_censor[1] < range_event[1])
74	10x	upper_censored <- as.numeric(range_censor[2] > range_event[2])
75	10x	range_with_cens_info <- c(range, lower_censored, upper_censored)
76	10x	list(
77	10x	quantiles_lower = with_label(
78	10x	unname(quantiles_lower),
79	10x	paste0(round(quantiles[1] * 100), "th percentile (", f_conf_level(conf_level), ")")
80		),
81	10x	median_ci_3d = with_label(unname(median_ci), paste0("Median (", f_conf_level(conf_level), ")")),
82	10x	quantiles_upper = with_label(
83	10x	unname(quantiles_upper),
84	10x	paste0(round(quantiles[3] * 100), "th percentile (", f_conf_level(conf_level), ")")
85		),
86	10x	range_with_cens_info = range_with_cens_info
87		)
88		}
89
90		#' @describeIn kaplan_meier Formatted analysis function which is used as `afun`
91		#'
92		#' @return
93		#' * `a_kaplan_meier()` returns the corresponding list with formatted [rtables::CellValue()].
94		#'
95		#' @examples
96		#' a_kaplan_meier(
97		#' df,
98		#' .var = 'AVAL',
99		#' is_event = 'is_event'
100		#' )
101		#'
102		#' basic_table() \|>
103		#' split_cols_by(var = 'ARMCD') \|>
104		#' add_colcounts() \|>
105		#' analyze(
106		#' vars = 'AVAL',
107		#' afun = a_kaplan_meier,
108		#' var_labels = 'Kaplan-Meier estimate of time to event (months)',
109		#' show_labels = 'visible',
110		#' extra_args = list(
111		#' is_event = 'is_event',
112		#' control = control_surv_time(conf_level = 0.9, conf_type = 'log-log')
113		#' )
114		#' ) \|>
115		#' build_table(df = adtte_f)
116		#'
117		#' @export
118		#' @order 2
119		a_kaplan_meier <- function(df, .var, ..., .stats = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) {
120		# Check for additional parameters to the statistics function
121	8x	dots_extra_args <- list(...)
122
123		# Only support default stats, not custom stats
124	8x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
125
126		# Apply statistics function
127	8x	x_stats <- .apply_stat_functions(
128	8x	default_stat_fnc = s_kaplan_meier,
129	8x	custom_stat_fnc_list = NULL,
130	8x	args_list = c(df = list(df), .var = .var, dots_extra_args)
131		)
132
133		# Format according to specifications
134	8x	format_stats(
135	8x	x_stats,
136	8x	method_groups = "kaplan_meier",
137	8x	stats_in = .stats,
138	8x	formats_in = .formats,
139	8x	labels_in = .labels,
140	8x	indents_in = .indent_mods
141		)
142		}

1		#' Tabulation for Exposure Tables
2		#'
3		#'
4		#' @details
5		#' Creates statistics needed for standard exposure table
6		#' This includes differences and 95% CI and total treatment years.
7		#' This is designed to be used as an analysis (afun in `analyze`) function.
8		#'
9		#' @name a_summarize_ex_j
10		NULL
11
12
13		#' @inheritParams proposal_argument_convention
14		#' @describeIn a_summarize_ex_j Statistics function needed for the exposure tables
15		#'
16		#' @param daysconv conversion required to get the values into days
17		#' (i.e 1 if original PARAMCD unit is days, 30.4375 if original PARAMCD unit is in months)
18		#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
19		#' If TRUE Ancova methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
20		#' @param comp_btw_group (`logical`)\cr If TRUE,
21		#' \cr When ancova = FALSE, the estimate of between group difference (on CHG) will be based upon two-sample t-test. \cr
22		#' \cr When ancova = TRUE, the same ancova model will be used for the estimate of between group difference (on CHG).
23		#'
24		#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
25		#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
26		#' @param conf_level (`proportion`)\cr Confidence level of the interval
27		#' @param variables (named list of strings)\cr
28		#' list of additional analysis variables, with expected elements:
29		#' * arm (string)\cr
30		#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
31		#' Specifically, the first level of arm variable is taken as the reference group.
32		#' * covariates (character)\cr
33		#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
34		#'
35		s_summarize_ex_j <- function(
36		df,
37		.var,
38		.df_row,
39		.spl_context,
40		comp_btw_group = TRUE,
41		ref_path = NULL,
42		ancova = FALSE,
43		interaction_y,
44		interaction_item,
45		conf_level,
46		daysconv,
47		variables
48		) {
49	5x	control <- control_analyze_vars()
50	5x	control$conf_level <- conf_level
51	5x	x_stats <- s_summary(df[[.var]], na.rm = TRUE, .var, control = control)
52		## add extra for subject years
53	5x	subj_years <- x_stats[["sum"]] * daysconv / 365.25
54	5x	x_stats[["total_subject_years"]] <- c(x_stats[["sum"]], subj_years)
55	5x	names(x_stats[["total_subject_years"]]) <- c("total", "subject_years")
56
57	5x	cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
58	5x	indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)
59
60	5x	if (indiffcol) {
61		# blank out all stats
62	2x	x_stats <- sapply(
63	2x	names(x_stats),
64	2x	FUN = function(x) {
65	60x	x_stats[[x]] <- NULL
66		},
67	2x	simplify = FALSE,
68	2x	USE.NAMES = TRUE
69		)
70		# diff between group will be updated in mean_sd stat
71	2x	if (comp_btw_group) {
72	2x	trt_var_refpath <- h_get_trtvar_refpath(ref_path, .spl_context, df)
73		# trt_var_refpath is list with elements trt_var trt_var_refspec cur_trt_grp ctrl_grp make these elements
74		# available in current environment
75	2x	trt_var <- trt_var_refpath$trt_var
76	2x	trt_var_refspec <- trt_var_refpath$trt_var_refspec
77	2x	cur_trt_grp <- trt_var_refpath$cur_trt_grp
78	2x	ctrl_grp <- trt_var_refpath$ctrl_grp
79
80	2x	.in_ref_col <- FALSE
81	!	if (trt_var == ctrl_grp) .in_ref_col <- TRUE
82
83	2x	.ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]
84
85	2x	if (ancova) {
86		# ancova method for diff between group
87	2x	x_stats2 <- s_summarize_ancova_j(
88	2x	df = df,
89	2x	.var = .var,
90	2x	.ref_group = .ref_group,
91	2x	.in_ref_col = .in_ref_col,
92	2x	.df_row = .df_row,
93	2x	conf_level = conf_level,
94	2x	interaction_y = interaction_y,
95	2x	interaction_item = interaction_item,
96	2x	variables = variables
97		)
98	2x	diffstat <- x_stats2[["lsmean_diffci"]]
99		} else {
100		# descriptive method for diff between group
101	!	x_stats2 <- s_summarize_desc_j(
102	!	df = df,
103	!	.var = .var,
104	!	.ref_group = .ref_group,
105	!	.in_ref_col = .in_ref_col,
106	!	control = control
107		)
108	!	diffstat <- x_stats2[["mean_diffci"]]
109		}
110		# actual update with the diffstat
111	2x	x_stats[["mean_sd"]] <- diffstat
112		}
113		}
114
115	5x	return(x_stats)
116		}
117
118		#' @title Analysis Function For Exposure Tables
119		#' @description
120		#' A function to create the appropriate statistics needed for exposure table
121		#' @details
122		#' Creates statistics needed for table. This includes differences and 95% CI and total treatment years.
123		#' This is designed to be used as an analysis (afun in `analyze`) function.
124		#' @inheritParams proposal_argument_convention
125		#'
126		#' @describeIn a_summarize_ex_j Formatted analysis function which is used as `afun`.
127		#'
128		#' @return
129		#' * `a_summarize_ex_j()` returns the corresponding list with formatted [rtables::CellValue()].
130		#'
131		#' @aliases a_summarize_ex_j
132		#' @examples
133		#' library(dplyr)
134		#'
135		#' ADEX <- data.frame(
136		#' USUBJID = c(
137		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
138		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
139		#' ),
140		#' TRT01A = c(
141		#' 'ARMA', 'ARMA', 'ARMA', 'ARMA', 'ARMA',
142		#' 'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMA'
143		#' ),
144		#' AVAL = c(56, 78, 67, 87, 88, 93, 39, 87, 65, 55)
145		#' )
146		#'
147		#' ADEX <- ADEX \|>
148		#' mutate(TRT01A = as.factor(TRT01A))
149		#'
150		#' ADEX$colspan_trt <- factor(ifelse(ADEX$TRT01A == 'Placebo', ' ', 'Active Study Agent'),
151		#' levels = c('Active Study Agent', ' ')
152		#' )
153		#'
154		#' ADEX$diff_header <- 'Difference in Means (95% CI)'
155		#' ADEX$diff_label <- paste(ADEX$TRT01A, paste('vs', 'Placebo'))
156		#'
157		#' colspan_trt_map <- create_colspan_map(ADEX,
158		#' non_active_grp = 'Placebo',
159		#' non_active_grp_span_lbl = ' ',
160		#' active_grp_span_lbl = 'Active Study Agent',
161		#' colspan_var = 'colspan_trt',
162		#' trt_var = 'TRT01A'
163		#' )
164		#' ref_path <- c('colspan_trt', '', 'TRT01A', 'Placebo')
165		#'
166		#' lyt <- basic_table() \|>
167		#' split_cols_by(
168		#' 'colspan_trt',
169		#' split_fun = trim_levels_to_map(map = colspan_trt_map)
170		#' ) \|>
171		#' split_cols_by('TRT01A') \|>
172		#' split_cols_by('diff_header', nested = FALSE) \|>
173		#' split_cols_by(
174		#' 'TRT01A',
175		#' split_fun = remove_split_levels('Placebo'),
176		#' labels_var = 'diff_label'
177		#' ) \|>
178		#' analyze('AVAL',
179		#' afun = a_summarize_ex_j, var_labels = 'Duration of treatment (Days)',
180		#' show_labels = 'visible',
181		#' indent_mod = 0L,
182		#' extra_args = list(
183		#' daysconv = 1,
184		#' ref_path = ref_path,
185		#' variables = list(arm = 'TRT01A', covariates = NULL),
186		#' ancova = TRUE,
187		#' comp_btw_group = TRUE
188		#' )
189		#' )
190		#'
191		#' result <- build_table(lyt, ADEX)
192		#'
193		#' result
194		#' @export
195		a_summarize_ex_j <- function(
196		df,
197		.var,
198		.df_row,
199		.spl_context,
200		comp_btw_group = TRUE,
201		ref_path = NULL,
202		ancova = FALSE,
203		interaction_y = FALSE,
204		interaction_item = NULL,
205		conf_level = 0.95,
206		variables,
207		.stats = c("mean_sd", "median", "range", "quantiles", "total_subject_years"),
208		.formats = c(diff_mean_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)")),
209		.labels = c(quantiles = "Interquartile range"),
210		.indent_mods = NULL,
211		na_str = rep("NA", 3),
212		daysconv = 1
213		) {
214	5x	if (!is.numeric(df[[.var]])) {
215	!	stop("a_summarize_ex_j issue: input variable must be numeric.")
216		}
217
218	5x	if (comp_btw_group && is.null(ref_path)) {
219	!	stop("a_summarize_ex_j issue: argument ref_path cannot be NULL.")
220		}
221
222	5x	if (comp_btw_group && ancova && is.null(variables)) {
223	!	stop("a_summarize_ex_j issue: argument variables must be defined when ancova is requested.")
224		}
225
226	5x	x_stats <- s_summarize_ex_j(
227	5x	df = df,
228	5x	.var = .var,
229	5x	.df_row = .df_row,
230	5x	.spl_context = .spl_context,
231	5x	comp_btw_group = comp_btw_group,
232	5x	ref_path = ref_path,
233	5x	ancova = ancova,
234	5x	interaction_y = interaction_y,
235	5x	interaction_item = interaction_item,
236	5x	conf_level = conf_level,
237	5x	daysconv = daysconv,
238	5x	variables = variables
239		)
240
241		# Fill in formatting defaults
242	5x	.stats_in <- .stats
243	5x	.stats <- tern_get_stats("analyze_vars_numeric", stats_in = .stats, custom_stats_in = NULL)
244	5x	if ("total_subject_years" %in% .stats_in) {
245		# place the extra statistic at the appropriate place within .stats vector
246	5x	i <- match("total_subject_years", .stats_in)
247	5x	x <- .stats_in[i:length(.stats_in)]
248	5x	if (length(x) == 1) {
249	5x	.stats <- c(.stats, "total_subject_years")
250		} else {
251	!	i2 <- min(match(x, .stats), na.rm = TRUE)
252	!	if (i2 == 1) {
253	!	.stats <- c("total_subject_years", .stats)
254		} else {
255	!	.stats <- c(.stats[1:(i2 - 1)], "total_subject_years", .stats[i2:length(.stats)])
256		}
257		}
258		}
259
260	5x	.stats_ext <- c(.stats, "diff_mean_est_ci")
261
262	5x	.formats <- junco_get_formats_from_stats(.stats_ext, .formats)
263	5x	.labels <- junco_get_labels_from_stats(.stats, .labels, label_attr_from_stats = get_label_attr_from_stats(x_stats))
264	5x	.indent_mods <- junco_get_indents_from_stats(.stats, .indent_mods)
265
266	5x	.names <- names(.labels)
267	5x	.labels <- .unlist_keep_nulls(.labels)
268	5x	.indent_mods <- .unlist_keep_nulls(.indent_mods)
269
270	5x	cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
271	5x	indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)
272
273	5x	if (indiffcol && comp_btw_group) {
274	2x	.formats[["mean_sd"]] <- .formats[["diff_mean_est_ci"]]
275		}
276	5x	.formats[["diff_mean_est_ci"]] <- NULL
277
278	5x	if (!is.null(na_str)) {
279	5x	.format_na_strs <- lapply(names(.formats), FUN = function(x) {
280	25x	na_str
281		})
282		} else {
283	!	.format_na_strs <- NULL
284		}
285
286	5x	x_stats <- x_stats[.stats]
287	5x	ret <- in_rows(
288	5x	.list = x_stats,
289	5x	.formats = .formats,
290	5x	.names = .names,
291	5x	.labels = .labels,
292	5x	.indent_mods = .indent_mods,
293	5x	.format_na_strs = .format_na_strs
294		)
295	5x	return(ret)
296		}

1		#' Relative risk estimation
2		#'
3		#' The analysis function [a_relative_risk()] is used to create a layout element
4		#' to estimate the relative risk for response within a studied population. Only
5		#' the CMH method is available currently.
6		#' The primary analysis variable, `vars`, is a logical variable indicating
7		#' whether a response has occurred for each record.
8		#' A stratification variable must be supplied via the
9		#' `strata` element of the `variables` argument.
10		#'
11		#' @details The variance of the CMH relative risk estimate is calculated using
12		#' the Greenland and Robins (1985) variance estimation.
13		#'
14		#' @param df (`data.frame`)\cr input data frame.
15		#' @param .var (`string`)\cr name of the response variable.
16		#' @param ref_path (`character`)\cr path to the reference group.
17		#' @param .spl_context (`environment`)\cr split context environment.
18		#' @param ... Additional arguments passed to the statistics function.
19		#' @param .stats (`character`)\cr statistics to calculate.
20		#' @param .formats (`list`)\cr formats for the statistics.
21		#' @param .labels (`list`)\cr labels for the statistics.
22		#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
23		#' @param .ref_group (`data.frame`)\cr reference group data frame.
24		#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
25		#' @param variables (`list`)\cr list with strata variable names.
26		#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
27		#' @param method (`string`)\cr method to use for relative risk calculation.
28		#' @param weights_method (`string`)\cr method to use for weights calculation in stratified analysis.
29		#'
30		#' @note This has been adapted from the `odds_ratio` functions in the `tern` package.
31		#'
32		#' @name relative_risk
33		NULL
34
35		#' @describeIn relative_risk Statistics function estimating the relative risk for response.
36		#'
37		#' @return
38		#' * `s_relative_risk()` returns a named list of elements `rel_risk_ci` and `pval`.
39		#'
40		#' @examples
41		#' nex <- 100 # Number of example rows
42		#' dta <- data.frame(
43		#' 'rsp' = sample(c(TRUE, FALSE), nex, TRUE),
44		#' 'grp' = sample(c('A', 'B'), nex, TRUE),
45		#' 'f1' = sample(c('a1', 'a2'), nex, TRUE),
46		#' 'f2' = sample(c('x', 'y', 'z'), nex, TRUE),
47		#' stringsAsFactors = TRUE
48		#' )
49		#'
50		#' s_relative_risk(
51		#' df = subset(dta, grp == 'A'),
52		#' .var = 'rsp',
53		#' .ref_group = subset(dta, grp == 'B'),
54		#' .in_ref_col = FALSE,
55		#' variables = list(strata = c('f1', 'f2')),
56		#' conf_level = 0.90
57		#' )
58		#' @export
59		s_relative_risk <- function(
60		df,
61		.var,
62		.ref_group,
63		.in_ref_col,
64		variables = list(strata = NULL),
65		conf_level = 0.95,
66		method = "cmh",
67		weights_method = "cmh"
68		) {
69	3x	method <- match.arg(method)
70	3x	weights_method <- match.arg(weights_method)
71	3x	checkmate::assert_character(variables$strata, null.ok = FALSE)
72	3x	y <- list(rel_risk_ci = list(), pval = list())
73
74	3x	if (!.in_ref_col) {
75	2x	rsp <- c(.ref_group[[.var]], df[[.var]])
76	2x	grp <- factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))
77
78	2x	strata_colnames <- variables$strata
79	2x	checkmate::assert_character(strata_colnames, null.ok = FALSE)
80	2x	strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)
81
82	2x	assert_df_with_variables(df, strata_vars)
83	2x	assert_df_with_variables(.ref_group, strata_vars)
84
85		# Merging interaction strata for reference group rows data and remaining
86	2x	strata <- c(interaction(.ref_group[strata_colnames]), interaction(df[strata_colnames]))
87	2x	strata <- as.factor(strata)
88
89	2x	y <- prop_ratio_cmh(rsp, grp, strata, conf_level)[c("rel_risk_ci", "pval")]
90
91	2x	one_group_no_events <- (sum(.ref_group[[.var]]) == 0) \|\| (sum(df[[.var]]) == 0)
92	2x	if (one_group_no_events) {
93	1x	y$rel_risk_ci <- c(est = NA_real_, lcl = 0, ucl = Inf)
94		}
95		}
96
97	3x	y$rel_risk_ci <- with_label(
98	3x	x = y$rel_risk_ci,
99	3x	label = paste0("Relative risk (", f_conf_level(conf_level), ")")
100		)
101	3x	y$pval <- unname(y$pval)
102
103	3x	y
104		}
105
106		#' @describeIn relative_risk Formatted analysis function which is used as `afun`. Note that the
107		#' junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
108		#'
109		#' @return
110		#' * `a_relative_risk()` returns the corresponding list with formatted [rtables::CellValue()].
111		#'
112		#' @examples
113		#' ## 'Mid' case: 4/4 respond in group A, 1/2 respond in group B.
114		#' nex <- 100 # Number of example rows
115		#' dta <- data.frame(
116		#' 'rsp' = sample(c(TRUE, FALSE), nex, TRUE),
117		#' 'grp' = sample(c('A', 'B'), nex, TRUE),
118		#' 'f1' = sample(c('a1', 'a2'), nex, TRUE),
119		#' 'f2' = sample(c('x', 'y', 'z'), nex, TRUE),
120		#' stringsAsFactors = TRUE
121		#' )
122		#'
123		#' l <- basic_table() \|>
124		#' split_cols_by(var = 'grp') \|>
125		#' analyze(
126		#' vars = 'rsp',
127		#' afun = a_relative_risk,
128		#' extra_args = list(
129		#' conf_level = 0.90,
130		#' variables = list(strata = 'f1'),
131		#' ref_path = c('grp', 'B')
132		#' )
133		#' )
134		#'
135		#' build_table(l, df = dta)
136		#' @export
137		#' @order 2
138		a_relative_risk <- function(
139		df,
140		.var,
141		ref_path,
142		.spl_context,
143		...,
144		.stats = NULL,
145		.formats = NULL,
146		.labels = NULL,
147		.indent_mods = NULL
148		) {
149		# Check for additional parameters to the statistics function
150	2x	dots_extra_args <- list(...)
151
152		# Only support default stats, not custom stats
153	2x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
154
155		# Obtain reference column information
156	2x	ref <- get_ref_info(ref_path, .spl_context)
157
158		# Apply statistics function
159	2x	x_stats <- .apply_stat_functions(
160	2x	default_stat_fnc = s_relative_risk,
161	2x	custom_stat_fnc_list = NULL,
162	2x	args_list = c(
163	2x	df = list(df),
164	2x	.var = .var,
165	2x	.ref_group = list(ref$ref_group),
166	2x	.in_ref_col = ref$in_ref_col,
167	2x	dots_extra_args
168		)
169		)
170
171		# Format according to specifications
172	2x	format_stats(
173	2x	x_stats,
174	2x	method_groups = "relative_risk",
175	2x	stats_in = .stats,
176	2x	formats_in = .formats,
177	2x	labels_in = .labels,
178	2x	indents_in = .indent_mods
179		)
180		}
181
182
183		#' @keywords internal
184		#' @importFrom purrr possibly
185		safe_mh_test <- purrr::possibly(stats::mantelhaen.test, otherwise = list(p.value = NA_real_))
186
187		#' Relative Risk CMH Statistic
188		#'
189		#' Calculates the relative risk which is defined as the ratio between the
190		#' response rates between the experimental treatment group and the control treatment group, adjusted
191		#' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights.
192		#'
193		#' @inheritParams proposal_argument_convention
194		#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
195		#'
196		#' @examples
197		#' # Cochran-Mantel-Haenszel confidence interval
198		#'
199		#' set.seed(2)
200		#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
201		#' grp <- sample(c('Placebo', 'Treatment'), 100, TRUE)
202		#' grp <- factor(grp, levels = c('Placebo', 'Treatment'))
203		#' strata_data <- data.frame(
204		#' 'f1' = sample(c('a', 'b'), 100, TRUE),
205		#' 'f2' = sample(c('x', 'y', 'z'), 100, TRUE),
206		#' stringsAsFactors = TRUE
207		#' )
208		#'
209		#' prop_ratio_cmh(
210		#' rsp = rsp, grp = grp, strata = interaction(strata_data),
211		#' conf_level = 0.90
212		#' )
213		#'
214		#' @export
215		prop_ratio_cmh <- function(rsp, grp, strata, conf_level = 0.95) {
216	4x	grp <- as_factor_keep_attributes(grp)
217	4x	strata <- as_factor_keep_attributes(strata)
218	4x	has_single_stratum <- nlevels(strata) == 1
219	4x	check_diff_prop_ci(
220	4x	rsp = rsp,
221	4x	grp = grp,
222	4x	conf_level = conf_level,
223	4x	strata = strata
224		)
225
226	4x	if (any(tapply(rsp, strata, length) < 5)) {
227	!	warning("Less than 5 observations in some strata.")
228		}
229
230		# first dimension: treatment, control - therefore we reverse the levels order 2nd dimension: TRUE, FALSE 3rd
231		# dimension: levels of strata rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
232	4x	t_tbl <- table(factor(grp, levels = rev(levels(grp))), factor(rsp, levels = c("TRUE", "FALSE")), strata)
233
234		# Index 1 is for treatment, index 2 is for control, e.g. n1 is number of treatment patients per stratum.
235	4x	n1resp <- t_tbl[1, 1, levels(strata)]
236	4x	n2resp <- t_tbl[2, 1, levels(strata)]
237
238	4x	t1 <- t_tbl[1, 1:2, , drop = TRUE]
239	4x	t2 <- t_tbl[2, 1:2, , drop = TRUE]
240	4x	if (has_single_stratum) {
241	!	n1 <- sum(t1)
242	!	n2 <- sum(t2)
243	!	checkmate::assert_count(n1)
244	!	checkmate::assert_count(n2)
245		} else {
246	4x	n1 <- colSums(t1)
247	4x	n2 <- colSums(t2)
248	4x	checkmate::assert_integerish(n1)
249	4x	checkmate::assert_integerish(n2)
250	4x	checkmate::assert_true(identical(length(n1), length(n2)))
251		}
252
253		# CMH statistic for relative risk, Treatment over Control
254	4x	use_stratum <- (n1 > 0) & (n2 > 0)
255	4x	n1 <- n1[use_stratum]
256	4x	n2 <- n2[use_stratum]
257	4x	n1resp <- n1resp[use_stratum]
258	4x	n2resp <- n2resp[use_stratum]
259	4x	nresp <- n1resp + n2resp
260	4x	n <- n1 + n2
261
262	4x	rel_risk_num <- sum(n1resp * n2 / n)
263	4x	rel_risk_denom <- sum(n2resp * n1 / n)
264	4x	log_rel_risk <- log(rel_risk_num) - log(rel_risk_denom)
265	4x	rel_risk <- exp(log_rel_risk)
266
267	4x	var_num <- sum((n1 * n2 * nresp - n1resp * n2resp * n) / n^2)
268	4x	var_denom <- rel_risk_num * rel_risk_denom
269	4x	var_log_rel_risk <- var_num / var_denom
270	4x	se_log_rel_risk <- sqrt(var_log_rel_risk)
271
272	4x	z <- stats::qnorm((1 + conf_level) / 2)
273	4x	log_rel_risk_ci <- log_rel_risk + c(-1, +1) * z * se_log_rel_risk
274	4x	ci <- exp(log_rel_risk_ci)
275	4x	rel_risk_ci <- stats::setNames(c(rel_risk, ci), c("est", "lcl", "ucl"))
276
277	4x	pval <- safe_mh_test(t_tbl, correct = FALSE)$p.value
278
279	4x	list(rel_risk_ci = rel_risk_ci, pval = pval)
280		}

1		#' Helper for Finding AVISIT after which CHG are all Missing
2		#'
3		#' @param df (`data.frame`)\cr with `CHG` and `AVISIT` variables.
4		#'
5		#' @return A string with either the factor level after which `AVISIT` is all missing,
6		#' or `NA`.
7		#' @export
8		#'
9		#' @examples
10		#' df <- data.frame(
11		#' AVISIT = factor(c(1, 2, 3, 4, 5)),
12		#' CHG = c(5, NA, NA, NA, 3)
13		#' )
14		#' find_missing_chg_after_avisit(df)
15		#'
16		#' df2 <- data.frame(
17		#' AVISIT = factor(c(1, 2, 3, 4, 5)),
18		#' CHG = c(5, NA, 3, NA, NA)
19		#' )
20		#' find_missing_chg_after_avisit(df2)
21		#'
22		#' df3 <- data.frame(
23		#' AVISIT = factor(c(1, 2, 3, 4, 5)),
24		#' CHG = c(NA, NA, NA, NA, NA)
25		#' )
26		#' find_missing_chg_after_avisit(df3)
27		find_missing_chg_after_avisit <- function(df) {
28	8x	checkmate::assert_data_frame(df)
29	7x	checkmate::assert_factor(df$AVISIT, unique = TRUE, any.missing = FALSE)
30	6x	checkmate::assert_numeric(df$CHG)
31
32		# Ensure the dataframe is sorted by AVISIT
33	5x	df <- df[order(df$AVISIT), ]
34
35		# Last visit with available data.
36	5x	visit_levels_available <- as.integer(df[!is.na(df$CHG), ]$AVISIT)
37
38	5x	if (!length(visit_levels_available)) {
39	1x	return(levels(df$AVISIT)[1])
40		}
41	4x	visit_levels_max_available <- max(visit_levels_available)
42
43		# Visits with missing data.
44	4x	visit_levels_missing <- as.integer(df[is.na(df$CHG), ]$AVISIT)
45
46		# Missing visits at the end.
47	4x	visit_levels_missing_end <- visit_levels_missing[visit_levels_missing > visit_levels_max_available]
48
49		# Return first one if there is any.
50	4x	if (length(visit_levels_missing_end)) {
51	3x	levels(df$AVISIT)[min(visit_levels_missing_end)]
52		} else {
53		NA_character_
54		}
55		}
56
57		# Copy from rbmi package, because this was only added recently, so not yet available in our package version.
58
59		#' Create a `rbmi` ready cluster
60		#'
61		#' @param cluster_or_cores Number of parallel processes to use or an existing cluster to make use of
62		#' @param objects a named list of objects to export into the sub-processes
63		#' @param packages a character vector of libraries to load in the sub-processes
64		#'
65		#' This function is a wrapper around `parallel::makePSOCKcluster()` but takes
66		#' care of configuring `rbmi` to be used in the sub-processes as well as loading
67		#' user defined objects and libraries and setting the seed for reproducibility.
68		#'
69		#' If `cluster_or_cores` is `1` this function will return `NULL`.
70		#'
71		#' If `cluster_or_cores` is a cluster created via `parallel::makeCluster()` then this function
72		#' just takes care of inserting the relevant `rbmi` objects into the existing cluster.
73		#'
74		#' @examples
75		#' # Basic usage # dontrun because .check_ncores
76		#' \dontrun{
77		#' make_rbmi_cluster(5)
78		#' closeAllConnections()
79		#'
80		#' # User objects + libraries
81		#' VALUE <- 5
82		#' myfun <- function(x) {
83		#' x + day(VALUE) # From lubridate::day()
84		#' }
85		#' make_rbmi_cluster(5, list(VALUE = VALUE, myfun = myfun), c('lubridate'))
86		#' closeAllConnections()
87		#'
88		#' # Using a already created cluster
89		#' cl <- parallel::makeCluster(5)
90		#' make_rbmi_cluster(cl)
91		#' closeAllConnections()
92		#' }
93		#' @export
94		make_rbmi_cluster <- function(cluster_or_cores = 1, objects = NULL, packages = NULL) {
95	6x	if (is.numeric(cluster_or_cores) && cluster_or_cores == 1) {
96	1x	return(NULL)
97	5x	} else if (is.numeric(cluster_or_cores)) {
98	2x	cl <- parallel::makePSOCKcluster(cluster_or_cores)
99	3x	} else if (methods::is(cluster_or_cores, "cluster")) {
100	2x	cl <- cluster_or_cores
101		} else {
102	1x	stop(sprintf("`cluster_or_cores` has unsupported class of: %s", paste(class(cluster_or_cores), collapse = ", ")))
103		}
104
105		# Load user defined objects into the globalname space
106	4x	if (!is.null(objects) && length(objects)) {
107	1x	export_env <- list2env(objects)
108	1x	parallel::clusterExport(cl, names(objects), export_env)
109		}
110
111		# Load user defined packages
112	4x	packages <- c(packages, "assertthat")
113		# Remove attempts to load `rbmi` as this will be covered later
114	4x	packages <- setdiff(packages, "rbmi")
115	4x	devnull <- parallel::clusterCall(
116	4x	cl,
117	4x	function(pkgs) lapply(pkgs, function(x) library(x, character.only = TRUE)),
118	4x	as.list(packages)
119		)
120
121		# Ensure reproducibility
122	4x	parallel::clusterSetRNGStream(cl, sample.int(1))
123
124		# If user has previously configured `rbmi` sub-processes then early exit
125	4x	exported_rbmi <- unlist(parallel::clusterEvalQ(cl, exists("..exported..parallel..rbmi")))
126	4x	if (all(exported_rbmi)) {
127	!	return(cl)
128		}
129
130		# Ensure that exported and unexported objects are all directly accessible from the globalenv in the sub-processes
131	4x	is_in_rbmi_development <- FALSE
132	4x	if (is_in_rbmi_development) {
133	!	devnull <- parallel::clusterEvalQ(cl, pkgload::load_all())
134		} else {
135	4x	devnull <- parallel::clusterEvalQ(cl, {
136	8x	.namespace <- getNamespace("rbmi")
137	8x	for (.nsfun in ls(.namespace)) {
138	1504x	assign(.nsfun, get(.nsfun, envir = .namespace))
139		}
140		})
141		}
142
143		# Set variable to signify `rbmi` has been configured
144	4x	devnull <- parallel::clusterEvalQ(cl, {
145	8x	..exported..parallel..rbmi <- TRUE
146		})
147
148	4x	return(cl)
149		}
150
151		#' Parallelise Lapply
152		#'
153		#' Simple wrapper around `lapply` and [`parallel::clusterApplyLB`] to abstract away
154		#' the logic of deciding which one to use
155		#' @param cl Cluster created by [`parallel::makeCluster()`] or `NULL`
156		#' @param fun Function to be run
157		#' @param x object to be looped over
158		#' @param ... extra arguments passed to `fun`
159		par_lapply <- function(cl, fun, x, ...) {
160	2x	result <- if (is.null(cl)) {
161	1x	lapply(x, fun, ...)
162		} else {
163	1x	parallel::clusterApplyLB(cl, x, fun, ...)
164		}
165	2x	return(result)
166		}
167
168		#' Analyse Multiple Imputed Datasets
169		#'
170		#' @description
171		#' This function takes multiple imputed datasets (as generated by
172		#' the [impute()] function) and runs an analysis function on
173		#' each of them.
174		#'
175		#' @importFrom assertthat assert_that
176		#'
177		#' @details
178		#' This function works by performing the following steps:
179		#'
180		#' 1. Extract a dataset from the `imputations` object.
181		#' 2. Apply any delta adjustments as specified by the `delta` argument.
182		#' 3. Run the analysis function `fun` on the dataset.
183		#' 4. Repeat steps 1-3 across all of the datasets inside the `imputations`
184		#' object.
185		#' 5. Collect and return all of the analysis results.
186		#'
187		#' The analysis function `fun` must take a `data.frame` as its first
188		#' argument. All other options to [rbmi_analyse()] are passed onto `fun`
189		#' via `...`.
190		#' `fun` must return a named list with each element itself being a
191		#' list containing a single
192		#' numeric element called `est` (or additionally `se` and `df` if
193		#' you had originally specified [method_bayes()] or [method_approxbayes()])
194		#' i.e.:
195		#' \preformatted{
196		#' myfun <- function(dat, ...) {
197		#' mod_1 <- lm(data = dat, outcome ~ group)
198		#' mod_2 <- lm(data = dat, outcome ~ group + covar)
199		#' x <- list(
200		#' trt_1 = list(
201		#' est = coef(mod_1)[['group']], # Use [[ ]] for safety
202		#' se = sqrt(vcov(mod_1)['group', 'group']), # Use ['','']
203		#' df = df.residual(mod_1)
204		#' ),
205		#' trt_2 = list(
206		#' est = coef(mod_2)[['group']], # Use [[ ]] for safety
207		#' se = sqrt(vcov(mod_2)['group', 'group']), # Use ['','']
208		#' df = df.residual(mod_2)
209		#' )
210		#' )
211		#' return(x)
212		#' }
213		#' }
214		#'
215		#' Please note that the `vars$subjid` column (as defined in the original call to
216		#' [draws()]) will be scrambled in the data.frames that are provided to `fun`.
217		#' This is to say they will not contain the original subject values and as such
218		#' any hard coding of subject ids is strictly to be avoided.
219		#'
220		#' By default `fun` is the [rbmi_ancova()] function.
221		#' Please note that this function
222		#' requires that a `vars` object, as created by [set_vars()], is provided via
223		#' the `vars` argument e.g. `rbmi_analyse(imputeObj, vars = rbmi::set_vars(...))`. Please
224		#' see the documentation for [rbmi_ancova()] for full details.
225		#' Please also note that the theoretical justification for the conditional mean imputation
226		#' method (`method = method_condmean()` in [draws()]) relies on the fact that ANCOVA is
227		#' a linear transformation of the outcomes.
228		#' Thus care is required when applying alternative analysis functions in this setting.
229		#'
230		#' The `delta` argument can be used to specify offsets to be applied
231		#' to the outcome variable in the imputed datasets prior to the analysis.
232		#' This is typically used for sensitivity or tipping point analyses. The
233		#' delta dataset must contain columns `vars$subjid`, `vars$visit` (as specified
234		#' in the original call to [draws()]) and `delta`. Essentially this `data.frame`
235		#' is merged onto the imputed dataset by `vars$subjid` and `vars$visit` and then
236		#' the outcome variable is modified by:
237		#'
238		#' ```
239		#' imputed_data[[vars$outcome]] <- imputed_data[[vars$outcome]] + imputed_data[['delta']]
240		#' ```
241		#'
242		#' Please note that in order to provide maximum flexibility, the `delta` argument
243		#' can be used to modify any/all outcome values including those that were not
244		#' imputed. Care must be taken when defining offsets. It is recommend that you
245		#' use the helper function [delta_template()] to define the delta datasets as
246		#' this provides utility variables such as `is_missing` which can be used to identify
247		#' exactly which visits have been imputed.
248		#'
249		#' @seealso [extract_imputed_dfs()] for manually extracting imputed
250		#' datasets.
251		#' @seealso [delta_template()] for creating delta data.frames.
252		#' @seealso [rbmi_ancova()] for the default analysis function.
253		#'
254		#' @param imputations An `imputations` object as created by [impute()].
255		#' @param fun An analysis function to be applied to each imputed dataset. See details.
256		#' @param delta A `data.frame` containing the delta transformation to be applied to the imputed
257		#' datasets prior to running `fun`. See details.
258		#' @param ... Additional arguments passed onto `fun`.
259		#' @param cluster_or_cores The number of parallel processes to use when running this function. Can also be a
260		#' cluster object created by [`make_rbmi_cluster()`]. See the parallelisation section below.
261		#' @param .validate Should `imputations` be checked to ensure it conforms to the required format
262		#' (default = `TRUE`) ? Can gain a small performance increase if this is set to `FALSE` when
263		#' analysing a large number of samples.
264		#'
265		#' @section Parallelisation:
266		#' To speed up the evaluation of `rbmi_analyse()` you can use the `cluster_or_cores` argument to enable parallelisation.
267		#' Simply providing an integer will get `rbmi` to automatically spawn that many background processes
268		#' to parallelise across. If you are using a custom analysis function then you need to ensure
269		#' that any libraries or global objects required by your function are available in the
270		#' sub-processes. To do this you need to use the [`make_rbmi_cluster()`] function for example:
271		#' ```
272		#' my_custom_fun <- function(...) <some analysis code>
273		#' cl <- make_rbmi_cluster(
274		#' 4,
275		#' objects = list('my_custom_fun' = my_custom_fun),
276		#' packages = c('dplyr', 'nlme')
277		#' )
278		#' rbmi_analyse(
279		#' imputations = imputeObj,
280		#' fun = my_custom_fun,
281		#' cluster_or_cores = cl
282		#' )
283		#' parallel::stopCluster(cl)
284		#' ```
285		#'
286		#' Note that there is significant overhead both with setting up the sub-processes and with
287		#' transferring data back-and-forth between the main process and the sub-processes. As such
288		#' parallelisation of the `rbmi_analyse()` function tends to only be worth it when you have
289		#' `> 2000` samples generated by [`draws()`]. Conversely using parallelisation if your samples
290		#' are smaller than this may lead to longer run times than just running it sequentially.
291		#'
292		#' It is important to note that the implementation of parallel processing within [`analyse()`] has
293		#' been optimised around the assumption that the parallel processes will be spawned on the same
294		#' machine and not a remote cluster. One such optimisation is that the required data is saved to
295		#' a temporary file on the local disk from which it is then read into each sub-process. This is
296		#' done to avoid the overhead of transferring the data over the network. Our assumption is that
297		#' if you are at the stage where you need to be parallelising your analysis over a remote cluster
298		#' then you would likely be better off parallelising across multiple `rbmi` runs rather than within
299		#' a single `rbmi` run.
300		#'
301		#' Finally, if you are doing a tipping point analysis you can get a reasonable performance
302		#' improvement by re-using the cluster between each call to `rbmi_analyse()` e.g.
303		#' ```
304		#' cl <- make_rbmi_cluster(4)
305		#' ana_1 <- rbmi_analyse(
306		#' imputations = imputeObj,
307		#' delta = delta_plan_1,
308		#' cluster_or_cores = cl
309		#' )
310		#' ana_2 <- rbmi_analyse(
311		#' imputations = imputeObj,
312		#' delta = delta_plan_2,
313		#' cluster_or_cores = cl
314		#' )
315		#' ana_3 <- rbmi_analyse(
316		#' imputations = imputeObj,
317		#' delta = delta_plan_3,
318		#' cluster_or_cores = cl
319		#' )
320		#' parallel::clusterStop(cl)
321		#' ```
322		#'
323		#' @examples
324		#' library(rbmi)
325		#' library(dplyr)
326		#'
327		#' dat <- antidepressant_data
328		#' dat$GENDER <- as.factor(dat$GENDER)
329		#' dat$POOLINV <- as.factor(dat$POOLINV)
330		#' dat <- expand_locf(
331		#' dat,
332		#' PATIENT = levels(dat$PATIENT),
333		#' # expand by PATIENT and VISIT
334		#' VISIT = levels(dat$VISIT),
335		#' vars = c("BASVAL", "THERAPY"),
336		#' # fill with LOCF BASVAL and THERAPY
337		#' group = c("PATIENT"),
338		#' order = c("PATIENT", "VISIT")
339		#' )
340		#' dat_ice <- dat %>%
341		#' arrange(PATIENT, VISIT) %>%
342		#' filter(is.na(CHANGE)) %>%
343		#' group_by(PATIENT) %>%
344		#' slice(1) %>%
345		#' ungroup() %>%
346		#' select(PATIENT, VISIT) %>%
347		#' mutate(strategy = "JR")
348		#' dat_ice <- dat_ice[-which(dat_ice$PATIENT == 3618), ]
349		#' vars <- set_vars(
350		#' outcome = "CHANGE",
351		#' visit = "VISIT",
352		#' subjid = "PATIENT",
353		#' group = "THERAPY",
354		#' covariates = c("THERAPY")
355		#' )
356		#' drawObj <- draws(
357		#' data = dat,
358		#' data_ice = dat_ice,
359		#' vars = vars,
360		#' method = method_condmean(type = "jackknife"),
361		#' quiet = TRUE
362		#' )
363		#' references <- c("DRUG" = "PLACEBO", "PLACEBO" = "PLACEBO")
364		#' imputeObj <- impute(drawObj, references)
365		#'
366		#' rbmi_analyse(imputations = imputeObj, vars = vars)
367		#' @export
368		rbmi_analyse <- function(imputations, fun = rbmi_ancova, delta = NULL, ..., cluster_or_cores = 1, .validate = TRUE) {
369		# nocov
370
371	!	if (.validate) rbmi::validate(imputations)
372
373	!	assertthat::assert_that(is.function(fun), msg = "`fun` must be a function")
374
375	!	assertthat::assert_that(is.null(delta) \| is.data.frame(delta), msg = "`delta` must be NULL or a data.frame")
376
377	!	vars <- imputations$data$vars
378
379	!	if (.validate) devnull <- lapply(imputations$imputations, function(x) rbmi::validate(x))
380
381	!	if (!is.null(delta)) {
382	!	expected_vars <- c(vars$subjid, vars$visit, "delta")
383	!	assertthat::assert_that(
384	!	all(expected_vars %in% names(delta)),
385	!	msg = sprintf("The following variables must exist witin `delta`: `%s`", paste0(expected_vars, collapse = "`, `"))
386		)
387		}
388
389		# Mangle name to avoid any conflicts with user defined objects if running in a cluster
390	!	..rbmi..analysis..imputations <- imputations
391	!	..rbmi..analysis..delta <- delta
392	!	..rbmi..analysis..fun <- fun
393	!	objects <- list(
394	!	..rbmi..analysis..imputations = ..rbmi..analysis..imputations,
395	!	..rbmi..analysis..delta = ..rbmi..analysis..delta,
396	!	..rbmi..analysis..fun = ..rbmi..analysis..fun
397		)
398
399	!	cl <- make_rbmi_cluster(cluster_or_cores)
400
401	!	if (methods::is(cl, "cluster")) {
402	!	..rbmi..analysis..data..path <- tempfile()
403	!	saveRDS(objects, file = ..rbmi..analysis..data..path, compress = FALSE)
404	!	devnull <- parallel::clusterExport(cl, "..rbmi..analysis..data..path", environment())
405	!	devnull <- parallel::clusterEvalQ(cl, {
406	!	..rbmi..analysis..objects <- readRDS(..rbmi..analysis..data..path)
407	!	list2env(..rbmi..analysis..objects, envir = environment())
408		})
409		}
410
411		# If the user provided the clusters object directly then do not close it on completion
412	!	if (!methods::is(cluster_or_cores, "cluster")) {
413	!	on.exit(
414		{
415	!	if (!is.null(cl)) parallel::stopCluster(cl)
416		},
417	!	add = TRUE,
418	!	after = FALSE
419		)
420		}
421
422		# Chunk up requests for significant speed improvement when running in parallel
423	!	number_of_cores <- ifelse(is.null(cl), 1, length(cl))
424	!	indexes <- seq_along(imputations$imputations)
425	!	indexes_split <- split(indexes, (indexes %% number_of_cores) + 1)
426
427	!	results <- par_lapply(
428	!	cl,
429	!	function(indicies, ...) {
430	!	inner_fun <- function(idx, ...) {
431	!	dat2 <- (utils::getFromNamespace("extract_imputed_df", "rbmi"))(
432	!	..rbmi..analysis..imputations$imputations[[idx]],
433	!	..rbmi..analysis..imputations$data,
434	!	..rbmi..analysis..delta
435		)
436	!	..rbmi..analysis..fun(dat2, ...)
437		}
438	!	lapply(indicies, inner_fun, ...)
439		},
440	!	indexes_split,
441		...
442		) \|>
443	!	unlist(recursive = FALSE, use.names = FALSE)
444
445		# Re-order to ensure results are returned in same order as imputations
446	!	results <- results[order(unlist(indexes_split, use.names = FALSE))]
447	!	names(results) <- NULL
448
449	!	fun_name <- deparse(substitute(fun))
450	!	if (length(fun_name) > 1) {
451	!	fun_name <- "<Anonymous Function>"
452	!	} else if (is.null(fun_name)) {
453	!	fun_name <- "<NULL>"
454		}
455
456	!	ret <- (utils::getFromNamespace("as_analysis", "rbmi"))(
457	!	results = results,
458	!	fun_name = fun_name,
459	!	delta = delta,
460	!	fun = fun,
461	!	method = imputations$method
462		)
463	!	rbmi::validate(ret)
464	!	return(ret)
465		}

1		#' @note This has been forked from [tern::h_ancova()], because the new
2		#' `weights_emmeans` option was added here.
3		h_ancova <- function(
4		.var,
5		.df_row,
6		variables,
7		weights_emmeans,
8		interaction_item = NULL
9		) {
10	17x	checkmate::assert_string(.var)
11	17x	checkmate::assert_list(variables)
12	17x	checkmate::assert_subset(names(variables), c("arm", "covariates"))
13
14	17x	assert_df_with_variables(
15	17x	.df_row,
16	17x	list(rsp = .var)
17		)
18	17x	arm <- variables$arm
19	17x	covariates <- variables$covariates
20	17x	if (!is.null(covariates) && length(covariates) > 0) {
21	7x	var_list <- get_covariates(covariates)
22	7x	assert_df_with_variables(
23	7x	.df_row,
24	7x	var_list
25		)
26		}
27	17x	covariates_part <- paste(covariates, collapse = " + ")
28	17x	formula_str <- paste0(.var, " ~ ", arm)
29	17x	if (covariates_part != "") {
30	7x	formula_str <- paste0(formula_str, "+", covariates_part)
31		}
32	17x	formula <- stats::as.formula(formula_str)
33	17x	specs <- arm
34	17x	if (!is.null(interaction_item)) {
35	!	specs <- c(specs, interaction_item)
36		}
37	17x	lm_fit <- stats::lm(formula = formula, data = .df_row)
38	17x	emmeans::emmeans(
39	17x	lm_fit,
40	17x	specs = specs,
41	17x	data = .df_row,
42	17x	weights = weights_emmeans
43		)
44		}
45
46		#' @title Junco Extended ANCOVA Function
47		#' @name s_ancova_j
48		#' @inheritParams tern::s_ancova
49		#' @param df : need to check on how to inherit params from tern::s_ancova
50		#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `"counterfactual"` by default.
51		#' @description Extension to tern:::s_ancova, 3 extra statistics are returned
52		#' * `lsmean_se`: Marginal mean and estimated SE in the group.
53		#' * `lsmean_ci`: Marginal mean and associated confidence interval in the group.
54		#' * `lsmean_diffci`: Difference in mean and associated confidence level in one combined statistic.
55		#' In addition, the LS mean weights can be specified.
56		#' In addition, also a NULL .ref_group can be specified, the lsmean_diff related estimates will be returned as NA.
57		#' @export
58		#' @return returns a named list of 8 statistics (3 extra compared to `tern:::s_ancova()`).
59		#' @family Inclusion of ANCOVA Functions
60		#' @examples
61		#' library(dplyr)
62		#' library(tern)
63		#'
64		#' df <- iris \|> filter(Species == "virginica")
65		#' .df_row <- iris
66		#' .var <- "Petal.Length"
67		#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
68		#' .ref_group <- iris \|> filter(Species == "setosa")
69		#' conf_level <- 0.95
70		#' s_ancova_j(df, .var, .df_row, variables, .ref_group, .in_ref_col = FALSE, conf_level)
71		s_ancova_j <- function(
72		df,
73		.var,
74		.df_row,
75		variables,
76		.ref_group,
77		.in_ref_col,
78		conf_level,
79		interaction_y = FALSE,
80		interaction_item = NULL,
81		weights_emmeans = "counterfactual"
82		) {
83	16x	arm <- variables$arm
84
85	16x	.df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
86	16x	df <- subset(df, !is.na(df[[.var]]))
87	16x	.ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))
88
89	16x	n_obs_trt_lvls <- length(unique(.df_row[[arm]]))
90
91		### sparse data problems with underlying ancova function
92	16x	if (NROW(.df_row) == 0) {
93	!	ret <- NULL
94	16x	} else if (NROW(df) == 0 \|\| n_obs_trt_lvls < 2) {
95		## all stats are NA
96	!	ret <- list(
97	!	n = with_label(0, "n"),
98	!	lsmean = with_label(NA, "Adjusted Mean"),
99	!	lsmean_se = with_label(rep(NA, 2), "Adjusted Mean (SE)"),
100	!	lsmean_ci = with_label(
101	!	rep(NA, 3),
102	!	paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
103		),
104	!	lsmean_diff = with_label(NA, "Difference in Adjusted Means"),
105	!	lsmean_diff_ci = with_label(
106	!	rep(NA, 2),
107	!	paste("Difference in Adjusted Means", f_conf_level(conf_level))
108		),
109	!	lsmean_diffci = with_label(
110	!	rep(NA, 3),
111	!	paste0(
112	!	"Difference in Adjusted Means",
113		" (",
114	!	f_conf_level(conf_level),
115		")"
116		)
117		),
118	!	pval = with_label(NA, "p-value")
119		)
120		} else {
121	16x	if (NROW(.ref_group) == 0) {
122	!	.ref_group <- NULL
123	16x	} else if (length(levels(.df_row[[arm]])) > n_obs_trt_lvls) {
124		# missing arm levels need to be removed from the factor, in order to have the correct estimates,
125		# and avoid errors with further code
126	!	.df_row[[arm]] <- droplevels(.df_row[[arm]])
127	!	df[[arm]] <- factor(
128	!	as.character(df[[arm]]),
129	!	levels = levels(.df_row[[arm]])
130		)
131	!	.ref_group[[arm]] <- factor(
132	!	as.character(.ref_group[[arm]]),
133	!	levels = levels(.df_row[[arm]])
134		)
135		}
136
137	16x	emmeans_fit <- h_ancova(
138	16x	.var = .var,
139	16x	variables = variables,
140	16x	.df_row = .df_row,
141	16x	weights_emmeans = weights_emmeans,
142	16x	interaction_item = interaction_item
143		)
144	16x	sum_fit <- summary(
145	16x	emmeans_fit,
146	16x	level = conf_level
147		)
148	16x	arm <- variables$arm
149	16x	sum_level <- as.character(unique(df[[arm]]))
150
151		# Ensure that there is only one element in sum_level.
152	16x	checkmate::assert_scalar(sum_level)
153
154	16x	sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]
155
156		# Get the index of the ref arm
157	16x	if (isTRUE(interaction_y)) {
158	!	y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])
159		# convert characters selected in interaction_y into the numeric order
160	!	interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)
161	!	sum_fit_level <- sum_fit_level[interaction_y, ]
162		# if interaction is called, reset the index
163	!	ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
164	!	ref_key <- utils::tail(ref_key, n = 1)
165	!	ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key
166		} else {
167	16x	y <- df[[.var]]
168		# Get the index of the ref arm when interaction is not called
169	16x	ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
170	16x	ref_key <- utils::tail(ref_key, n = 1)
171		}
172
173	16x	if (.in_ref_col) {
174	4x	ret <- list(
175	4x	n = with_label(length(y[!is.na(y)]), "n"),
176	4x	lsmean = with_label(sum_fit_level$emmean, "Adjusted Mean"),
177	4x	lsmean_se = with_label(
178	4x	c(sum_fit_level$emmean, sum_fit_level$SE),
179	4x	"Adjusted Mean (SE)"
180		),
181	4x	lsmean_ci = with_label(
182	4x	c(
183	4x	sum_fit_level$emmean,
184	4x	sum_fit_level$lower.CL,
185	4x	sum_fit_level$upper.CL
186		),
187	4x	paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
188		),
189	4x	lsmean_diff = with_label(
190	4x	character(),
191	4x	"Difference in Adjusted Means"
192		),
193	4x	lsmean_diff_ci = with_label(
194	4x	character(),
195	4x	paste("Difference in Adjusted Means", f_conf_level(conf_level))
196		),
197	4x	lsmean_diffci = with_label(
198	4x	character(),
199	4x	paste0(
200	4x	"Difference in Adjusted Means",
201		" (",
202	4x	f_conf_level(conf_level),
203		")"
204		)
205		),
206	4x	pval = with_label(character(), "p-value")
207		)
208		} else {
209	12x	if (!is.null(.ref_group)) {
210		# Estimate the differences between the marginal means.
211	12x	emmeans_contrasts <- emmeans::contrast(
212	12x	emmeans_fit,
213		# Compare all arms versus the control arm.
214	12x	method = "trt.vs.ctrl",
215		# Take the arm factor from .ref_group as the control arm.
216	12x	ref = ref_key,
217	12x	level = conf_level
218		)
219	12x	sum_contrasts <- summary(
220	12x	emmeans_contrasts,
221		# Derive confidence intervals, t-tests and p-values.
222	12x	infer = TRUE,
223		# Do not adjust the p-values for multiplicity.
224	12x	adjust = "none"
225		)
226	12x	contrast_lvls <- gsub(
227	12x	paste0(" - ", .ref_group[[arm]][1], ".*"),
228		"",
229	12x	sum_contrasts$contrast
230		)
231	12x	if (!is.null(interaction_item)) {
232	!	sum_contrasts_level <- sum_contrasts[
233	!	grepl(sum_level, contrast_lvls, fixed = TRUE), , drop = FALSE
234		]
235		} else {
236	12x	sum_contrasts_level <- sum_contrasts[
237	12x	(sum_level == contrast_lvls \| paste0("(", sum_level, ")") == contrast_lvls), , drop = FALSE
238		]
239		}
240	12x	if (interaction_y != FALSE) {
241	!	sum_contrasts_level <- sum_contrasts_level[interaction_y, , drop = FALSE]
242		}
243		} else {
244	!	sum_contrasts_level <- list()
245	!	sum_contrasts_level[["estimate"]] <- NA
246	!	sum_contrasts_level[["lower.CL"]] <- NA
247	!	sum_contrasts_level[["upper.CL"]] <- NA
248	!	sum_contrasts_level[["p.value"]] <- NA
249		}
250	12x	ret <- list(
251	12x	n = with_label(length(y[!is.na(y)]), "n"),
252	12x	lsmean = with_label(sum_fit_level$emmean, "Adjusted Mean"),
253	12x	lsmean_se = with_label(
254	12x	c(sum_fit_level$emmean, sum_fit_level$SE),
255	12x	"Adjusted Mean (SE)"
256		),
257	12x	lsmean_ci = with_label(
258	12x	c(
259	12x	sum_fit_level$emmean,
260	12x	sum_fit_level$lower.CL,
261	12x	sum_fit_level$upper.CL
262		),
263	12x	paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
264		),
265	12x	lsmean_diff = with_label(
266	12x	sum_contrasts_level$estimate,
267	12x	"Difference in Adjusted Means"
268		),
269	12x	lsmean_diff_ci = with_label(
270	12x	c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),
271	12x	paste("Difference in Adjusted Means", f_conf_level(conf_level))
272		),
273	12x	lsmean_diffci = with_label(
274	12x	c(
275	12x	sum_contrasts_level$estimate,
276	12x	sum_contrasts_level$lower.CL,
277	12x	sum_contrasts_level$upper.CL
278		),
279	12x	paste0(
280	12x	"Difference in Adjusted Means",
281		" (",
282	12x	f_conf_level(conf_level),
283		")"
284		)
285		),
286	12x	pval = with_label(sum_contrasts_level$p.value, "p-value")
287		)
288		}
289		}
290	16x	return(ret)
291		}
292
293		#' @name s_summarize_ancova_j
294		#' @title ANCOVA Summary Function
295		#' @description Combination of tern::s_summary, and ANCOVA based estimates for mean and diff between columns,
296		#' based on ANCOVA function `s_ancova_j`
297		#' @inherit s_ancova_j
298		#' @param ... Additional arguments passed to `s_ancova_j`.
299		#' @details Combination of tern::s_summary, and ANCOVA based estimates for mean and diff between columns,
300		#' based on ANCOVA function `s_ancova_j`
301		#' @return returns the statistics from tern::s_summary(x), appended with a new statistics based upon ANCOVA
302		#' @export
303		#' @family Inclusion of ANCOVA Functions
304		# @seealso s_ancova_j
305		#' @examples
306		#' library(dplyr)
307		#' library(tern)
308		#'
309		#' df <- iris \|> filter(Species == "virginica")
310		#' .df_row <- iris
311		#' .var <- "Petal.Length"
312		#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
313		#' .ref_group <- iris \|> filter(Species == "setosa")
314		#' conf_level <- 0.95
315		#' s_summarize_ancova_j(
316		#' df,
317		#' .var = .var,
318		#' .df_row = .df_row,
319		#' variables = variables,
320		#' .ref_group = .ref_group,
321		#' .in_ref_col = FALSE,
322		#' conf_level = conf_level
323		#' )
324		s_summarize_ancova_j <- function(
325		df,
326		.var,
327		.df_row,
328		.ref_group,
329		.in_ref_col,
330		...
331		) {
332	14x	x <- df[[.var]]
333	14x	y1 <- s_summary(x)
334	14x	y2 <- s_ancova_j(
335	14x	df = df,
336	14x	.var = .var,
337	14x	.ref_group = .ref_group,
338	14x	.in_ref_col = .in_ref_col,
339	14x	.df_row = .df_row,
340		...
341		)
342	14x	c(y1, y2)
343		}
344
345		#' @describeIn s_summarize_ancova_j Formatted analysis function which is used as `afun`. Note that the
346		#' junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
347		#'
348		#' @param ref_path (`character`)\cr path to the reference group.
349		#' @param .spl_context (`environment`)\cr split context environment.
350		#' @param ... Additional arguments passed to the statistics function.
351		#' @param .stats (`character`)\cr statistics to calculate.
352		#' @param .formats (`list`)\cr formats for the statistics.
353		#' @param .labels (`list`)\cr labels for the statistics.
354		#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
355		#'
356		#' @return
357		#' * `a_summarize_ancova_j()` returns the corresponding list with formatted [rtables::CellValue()].
358		#'
359		#' @examples
360		#'
361		#' basic_table() \|>
362		#' split_cols_by("Species") \|>
363		#' add_colcounts() \|>
364		#' analyze(
365		#' vars = "Petal.Length",
366		#' afun = a_summarize_ancova_j,
367		#' show_labels = "hidden",
368		#' na_str = tern::default_na_str(),
369		#' table_names = "unadj",
370		#' var_labels = "Unadjusted comparison",
371		#' extra_args = list(
372		#' variables = list(arm = "Species", covariates = NULL),
373		#' conf_level = 0.95,
374		#' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means"),
375		#' ref_path = c("Species", "setosa")
376		#' )
377		#' ) \|>
378		#' analyze(
379		#' vars = "Petal.Length",
380		#' afun = a_summarize_ancova_j,
381		#' show_labels = "hidden",
382		#' na_str = tern::default_na_str(),
383		#' table_names = "adj",
384		#' var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)",
385		#' extra_args = list(
386		#' variables = list(
387		#' arm = "Species",
388		#' covariates = c("Sepal.Length", "Sepal.Width")
389		#' ),
390		#' conf_level = 0.95,
391		#' ref_path = c("Species", "setosa")
392		#' )
393		#' ) \|>
394		#' build_table(iris)
395		#'
396		#' @export
397		#' @order 2
398		a_summarize_ancova_j <- function(
399		df,
400		.var,
401		.df_row,
402		ref_path,
403		.spl_context,
404		...,
405		.stats = NULL,
406		.formats = NULL,
407		.labels = NULL,
408		.indent_mods = NULL
409		) {
410		# Check for additional parameters to the statistics function
411	6x	dots_extra_args <- list(...)
412
413		# Only support default stats, not custom stats
414	6x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
415
416		# Obtain reference column information
417	6x	ref <- get_ref_info(ref_path, .spl_context)
418
419		# Apply statistics function
420	6x	x_stats <- .apply_stat_functions(
421	6x	default_stat_fnc = s_summarize_ancova_j,
422	6x	custom_stat_fnc_list = NULL,
423	6x	args_list = c(
424	6x	df = list(df),
425	6x	.var = .var,
426	6x	.df_row = list(.df_row),
427	6x	.ref_group = list(ref$ref_group),
428	6x	.in_ref_col = ref$in_ref_col,
429	6x	dots_extra_args
430		)
431		)
432
433		# Format according to specifications
434	6x	format_stats(
435	6x	x_stats,
436	6x	method_groups = "summarize_ancova_j",
437	6x	stats_in = .stats,
438	6x	formats_in = .formats,
439	6x	labels_in = .labels,
440	6x	indents_in = .indent_mods
441		)
442		}

1		#' `ANCOVA` Analysis
2		#'
3		#' Does the `ANCOVA` analysis, separately for each visit.
4		#'
5		#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `ANCOVA` analysis.
6		#' The following elements need to be included as character vectors and match corresponding columns
7		#' in `data`:
8		#'
9		#' - `response`: the response variable.
10		#' - `covariates`: the additional covariate terms (might also include interactions).
11		#' - `id`: the subject ID variable (not really needed for the computations but for internal logistics).
12		#' - `arm`: the treatment group variable (factor).
13		#' - `visit`: the visit variable (factor).
14		#'
15		#' Note that the `arm` variable is by default included in the model, thus should not be part of `covariates`.
16		#' @param data (`data.frame`)\cr with all the variables specified in
17		#' `vars`. Records with missing values in any independent variables
18		#' will be excluded.
19		#' @param conf_level (`proportion`)\cr confidence level of the interval.
20		#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
21		#'
22		#' @return A `tern_model` object which is a list with model results:
23		#'
24		#' - `fit`: A list with a fitted [stats::lm()] result for each visit.
25		#' - `mse`: Mean squared error, i.e. variance estimate, for each visit.
26		#' - `df`: Degrees of freedom for the variance estimate for each visit.
27		#' - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
28		#' The attribute `weights` savse the settings used (`weights_emmeans`).
29		#' - `vars`: The variable list.
30		#' - `labels`: Corresponding list with variable labels extracted from `data`.
31		#' - `ref_level`: The reference level for the arm variable, which is always the first level.
32		#' - `treatment_levels`: The treatment levels for the arm variable.
33		#' - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
34		#'
35		#' @export
36		#' @examples
37		#' library(mmrm)
38		#'
39		#' fit <- fit_ancova(
40		#' vars = list(
41		#' response = 'FEV1',
42		#' covariates = c('RACE', 'SEX'),
43		#' arm = 'ARMCD',
44		#' id = 'USUBJID',
45		#' visit = 'AVISIT'
46		#' ),
47		#' data = fev_data,
48		#' conf_level = 0.9,
49		#' weights_emmeans = 'equal'
50		#' )
51		#'
52		fit_ancova <- function(
53		vars = list(response = "AVAL", covariates = c(), arm = "ARM", visit = "AVISIT", id = "USUBJID"),
54		data,
55		conf_level = 0.95,
56		weights_emmeans = "proportional"
57		) {
58	5x	labels <- h_labels(vars, data)
59
60	5x	arm_levels <- levels(data[[vars$arm]])
61	5x	ref_level <- arm_levels[1]
62	5x	trt_levels <- arm_levels[-1]
63	5x	visit_levels <- levels(data[[vars$visit]])
64	5x	grid <- list(
65	5x	factor(arm_levels, levels = arm_levels),
66	5x	factor(rep(visit_levels, each = length(arm_levels)), levels = visit_levels)
67		) \|>
68	5x	stats::setNames(c(vars$arm, vars$visit)) \|>
69	5x	as.data.frame()
70	5x	checkmate::assert_disjunct(vars$arm, vars$covariates)
71	5x	covariates_part <- paste(vars$covariates, collapse = " + ")
72	5x	formula <- if (covariates_part != "") {
73	5x	stats::as.formula(paste0(vars$response, " ~ ", covariates_part, " + ", vars$arm))
74		} else {
75	!	stats::as.formula(paste0(vars$response, " ~ ", vars$arm))
76		}
77	5x	results_by_visit <- Map(
78	5x	data = split(data, data[[vars$visit]]),
79	5x	grid = split(grid, grid[[vars$visit]]),
80	5x	f = function(data, grid) {
81	20x	fit <- stats::lm(formula = formula, data = data)
82	20x	summary_fit <- summary(fit)
83	20x	emmeans_res <- h_get_emmeans_res(fit, vars = vars["arm"], weights = weights_emmeans)
84	20x	estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
85	20x	estimates[[vars$visit]] <- grid[[vars$visit]]
86	20x	estimates <- estimates \|> dplyr::relocate(!!vars$arm, !!vars$visit)
87	20x	contrasts <- h_get_spec_visit_estimates(
88	20x	emmeans_res,
89	20x	specs = list(
90	20x	coefs = "trt.vs.ctrl",
91	20x	grid = grid[-1, ] # Without the reference level row.
92		),
93	20x	conf_level = conf_level,
94	20x	tests = TRUE,
95	20x	ref = ref_level
96		)
97	20x	relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
98	20x	contrasts <- merge(contrasts, relative_reduc_df, by = c(vars$arm, vars$visit), sort = FALSE)
99	20x	list(fit = fit, estimates = estimates, contrasts = contrasts, mse = summary_fit$sigma^2, df = summary_fit$df[2])
100		}
101		)
102	5x	lsmeans <- structure(
103	5x	list(
104	5x	estimates = do.call(rbind, c(lapply(results_by_visit, "[[", "estimates"), make.row.names = FALSE)),
105	5x	contrasts = do.call(rbind, c(lapply(results_by_visit, "[[", "contrasts"), make.row.names = FALSE))
106		),
107	5x	weights = weights_emmeans
108		)
109	5x	results <- list(
110	5x	fit = lapply(results_by_visit, "[[", "fit"),
111	5x	mse = do.call(c, lapply(results_by_visit, "[[", "mse")),
112	5x	df = do.call(c, lapply(results_by_visit, "[[", "df")),
113	5x	lsmeans = lsmeans,
114	5x	vars = vars,
115	5x	labels = labels,
116	5x	ref_level = ref_level,
117	5x	treatment_levels = trt_levels,
118	5x	conf_level = conf_level
119		)
120	5x	class(results) <- "tern_model"
121	5x	results
122		}

1		#' @name response_by_var
2		#' @title Count denom fraction statistic
3		#'
4		#' @description Derives the count_denom_fraction statistic (i.e., 'xx /xx (xx.x percent)' )
5		#' Summarizes the number of unique subjects with a response = 'Y' for a given variable
6		#' (e.g. TRTEMFL) within each category of another variable (e.g., SEX).
7		#' Note that the denominator is derived using input df,
8		#' in order to have these aligned with alt_source_df, it is expected that df includes all subjects.
9		#'
10		#' @details This is an analysis function for use within `analyze`. Arguments
11		#' `df`, `.var` will be populated automatically by rtables during
12		#' the tabulation process.
13		#'
14		#' @param df Name of dataframe being analyzed.
15		#' @param labelstr Custom label for the variable being analyzed.
16		#' @param .var Name of the variable being analyzed. Records with non-missing
17		#' values will be counted in the denominator.
18		#' @param .N_col numeric(1). The total for the current column.
19		#' @param resp_var Name of variable, for which, records with a value of 'Y'
20		#' will be counted in the numerator.
21		#' @param id Name of column in df which will have patient identifiers
22		#' @param .format Format for the count/denominator/fraction output.
23		#' @param ... Additional arguments passed to the function.
24		# @examples #analyze(vars='AGEGR1_DECODE', var_labels = 'Age group (years), n/Ns (%)', afun = response_by_var,
25		# extra_args = list(resp_var = 'TRTEMFL'))
26		#' @examples
27		#'
28		#' library(dplyr)
29		#'
30		#' ADAE <- data.frame(
31		#' USUBJID = c(
32		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
33		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
34		#' ),
35		#' SEX_DECODE = c(
36		#' 'Female', 'Female', 'Male', 'Female', 'Male',
37		#' 'Female', 'Male', 'Female', 'Male', 'Female'
38		#' ),
39		#' TRT01A = c(
40		#' 'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
41		#' 'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
42		#' ),
43		#' TRTEMFL = c('Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y')
44		#' )
45		#'
46		#' ADAE <- ADAE \|>
47		#' mutate(
48		#' TRT01A = as.factor(TRT01A),
49		#' SEX_DECODE = as.factor(SEX_DECODE)
50		#' )
51		#'
52		#' lyt <- basic_table() \|>
53		#' split_cols_by('TRT01A') \|>
54		#' analyze(
55		#' vars = 'SEX_DECODE',
56		#' var_labels = 'Sex, n/Ns (%)',
57		#' show_labels = 'visible',
58		#' afun = response_by_var,
59		#' extra_args = list(resp_var = 'TRTEMFL'),
60		#' nested = FALSE
61		#' )
62		#'
63		#' result <- build_table(lyt, ADAE)
64		#'
65		#' result
66		#' @returns a `RowsVerticalSection` for use by the internal tabulation machinery of `rtables`
67		#' @export
68
69		response_by_var <- function(
70		df,
71		labelstr = NULL,
72		.var,
73		.N_col,
74		resp_var = NULL,
75		id = "USUBJID",
76		.format = jjcsformat_count_denom_fraction,
77		...
78		) {
79		# Derive statistics: xx / xx (xx.x%)
80
81	15x	if (is.null(resp_var)) {
82	!	stop("afun response_by_var: resp_var cannot be NULL.")
83		}
84
85	15x	resp_var_values <- unique(df[[resp_var]][!is.na(df[[resp_var]])])
86	15x	if (is.character(df[[resp_var]]) && any(is.na(df[[resp_var]])) && all(resp_var_values == "Y")) {
87	!	stop(paste(
88	!	"afun response_by_var: not clear if missing resp_var should be considered",
89	!	"non-response. Please make it a factor with appropriate Y(/N) levels."
90		))
91		}
92
93	15x	if (length(setdiff(resp_var_values, c("Y", "N"))) > 0) {
94	!	stop("afun response_by_var: resp_var must contain only Y/N values.")
95		}
96
97	15x	df <- df[!is.na(df[[.var]]), ]
98
99		if (
100	15x	(is.factor(df[[resp_var]]) &&
101	15x	(identical(levels(df[[resp_var]]), c("Y", "N")) \|\| identical(levels(df[[resp_var]]), c("N", "Y")))) \|\|
102	15x	is.character(df[[resp_var]])
103		) {
104		# missing values in resp_var should be excluded, not considered as not met response subject will then not
105		# contribute to denominator
106	9x	df <- df[!is.na(df[[resp_var]]), ]
107		}
108
109		## in other cases, missing values in resp_var will be considered not met response and subject will contribute to
110		## denominator
111	15x	varvec <- df[[.var]]
112
113		# For group summaries, varvec will be a singular value, equal to the current split, whereas for afun summaries,
114		# varvec will consist of all possible values of var.
115	15x	if (!is.null(labelstr)) {
116	!	levs <- labelstr
117		} else {
118	15x	levs <- if (is.factor(varvec)) levels(varvec) else unique(varvec)
119		}
120
121	15x	fn <- function(levii) {
122	63x	dfii <- df[df[[.var]] == levii, ]
123
124	63x	den <- NROW(unique(dfii[, id]))
125	63x	num <- NROW(unique(dfii[dfii[[resp_var]] == "Y" & !is.na(dfii[[resp_var]]), id]))
126
127	63x	rcell(c(num * 1, den * 1, num * 1 / den), format = .format)
128		}
129
130	15x	cls <- lapply(levs, fn)
131	15x	names(cls) <- levs
132
133		# Hand off results to analyze
134
135	15x	in_rows(.list = cls)
136		}

1		#' @name a_freq_subcol_j
2		#'
3		#' @title Analysis function count and percentage with extra column-subsetting in
4		#' selected columns (controlled by subcol_* arguments)
5		#'
6		#' @inheritParams proposal_argument_convention
7		#' @inheritParams a_freq_j
8		#' @param subcol_split Text to search colid to determine whether further subsetting
9		#' should be performed.
10		#' @param subcol_var Name of variable containing to be searched for the text
11		#' identified in subcol_val argument.
12		#' @param subcol_val Value to use to perform further data sub-setting.
13
14		#' @param denom (`string`)\cr
15		#' One of \cr
16		#' \itemize{
17		#' \item \strong{N_col} Column count, \cr
18		#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
19		#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
20		#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
21		#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
22		#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
23		#' (`.row_df` from the rtables splitting machinery).\cr
24		#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
25		#' This higher row-level split is specified in the argument `denom_by`.\cr
26		#' }
27		#' @param .formats (named 'character' or 'list')\cr
28		#' formats for the statistics.
29		#'
30		#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
31		#' @export
32
33		a_freq_subcol_j <- function(
34		df,
35		labelstr = NULL,
36		.var = NA,
37		val = NULL,
38		# arguments specific to a_freq_subcol_j
39		subcol_split = NULL,
40		subcol_var = NULL,
41		subcol_val = NULL,
42		# arguments specific to a_freq_subcol_j till here
43		.df_row,
44		.spl_context,
45		.N_col,
46		id = "USUBJID",
47		denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
48		label = NULL,
49		label_fstr = NULL,
50		label_map = NULL,
51		.alt_df_full = NULL,
52		denom_by = NULL,
53		.stats = c("count_unique_denom_fraction"),
54		.formats = NULL,
55		.labels_n = NULL,
56		.indent_mods = NULL,
57		na_str = rep("NA", 3)
58		) {
59	6x	denom <- match.arg(denom)
60
61	6x	if (!is.null(labelstr) && is.na(.var)) {
62	!	stop(
63	!	"Argument var must be specified in call to summarize_row_groups when using cfun = a_freq_subcol_j."
64		)
65		}
66
67	6x	if (denom %in% c("n_altdf") && is.null(.alt_df_full)) {
68	!	stop(".alt_df_full cannot be NULL when denom = n_altdf.")
69		}
70
71	6x	res_dataprep <- h_a_freq_dataprep(
72	6x	df = df,
73	6x	labelstr = labelstr,
74	6x	.var = .var,
75	6x	val = val,
76	6x	drop_levels = FALSE,
77	6x	excl_levels = NULL,
78	6x	new_levels = NULL,
79	6x	new_levels_after = FALSE,
80	6x	.df_row = .df_row,
81	6x	.spl_context = .spl_context,
82	6x	.N_col = .N_col,
83	6x	id = id,
84	6x	denom = denom,
85	6x	variables = NULL,
86	6x	label = label,
87	6x	label_fstr = label_fstr,
88	6x	label_map = label_map,
89	6x	.alt_df_full = .alt_df_full,
90	6x	denom_by = denom_by,
91	6x	.stats = .stats
92		)
93		# res_dataprep is list with elements
94		# df .df_row val
95		# drop_levels excl_levels
96		# alt_df parentdf new_denomdf
97		# .stats
98		# make these elements available in current environment
99	6x	df <- res_dataprep$df
100	6x	.df_row <- res_dataprep$.df_row
101	6x	val <- res_dataprep$val
102	6x	alt_df <- res_dataprep$alt_df
103	6x	parentdf <- res_dataprep$parentdf
104	6x	new_denomdf <- res_dataprep$new_denomdf
105	6x	.stats <- .stats
106
107		## colid can be used to figure out if we're in subcolum
108	6x	colid <- .spl_context$cur_col_id[[1]]
109
110		### this is the core code for subsetting to appropriate subcol_val
111	6x	insubcol <- grepl(subcol_split, colid, fixed = TRUE)
112	6x	if (insubcol) {
113	3x	df <- subset(df, df[[subcol_var]] == subcol_val)
114		}
115
116		## the same s-function can be used as in a_freq_j
117	6x	x_stats <- s_freq_j(
118	6x	df,
119	6x	.var = .var,
120	6x	.df_row = .df_row,
121	6x	val = val,
122	6x	alt_df = new_denomdf,
123	6x	parent_df = new_denomdf,
124	6x	id = id,
125	6x	denom = denom,
126	6x	.N_col = .N_col,
127	6x	countsource = "df"
128		)
129
130	6x	.stats_adj <- .stats
131
132	6x	res_prepinrows <- h_a_freq_prepinrows(
133	6x	x_stats,
134	6x	.stats_adj,
135	6x	.formats,
136	6x	labelstr,
137	6x	label_fstr,
138	6x	label,
139	6x	.indent_mods,
140	6x	.labels_n,
141	6x	na_str
142		)
143		# res_prepinrows is list with elements
144		# x_stats .formats .labels .indent_mods .format_na_strs
145		# make these elements available in current environment
146	6x	x_stats <- res_prepinrows$x_stats
147	6x	.formats <- res_prepinrows$.formats
148	6x	.labels <- res_prepinrows$.labels
149	6x	.indent_mods <- res_prepinrows$.indent_mods
150	6x	.format_na_strs <- res_prepinrows$.format_na_strs
151
152		### final step: turn requested stats into rtables rows
153	6x	inrows <- in_rows(
154	6x	.list = x_stats,
155	6x	.formats = .formats,
156	6x	.labels = .labels,
157	6x	.indent_mods = .indent_mods,
158	6x	.format_na_strs = .format_na_strs
159		)
160
161	6x	return(inrows)
162		}

1		#' @title Function factory for xx style formatting
2		#' @description A function factory to generate formatting functions for value
3		#' formatting that support the xx style format and control the rounding method
4		#'
5		#' @param roundmethod (`string`)\cr choice of rounding methods. Options are:
6		#' * `sas`: the underlying rounding method is `tidytlg::roundSAS`, where \cr
7		#' roundSAS comes from this Stack Overflow post https://stackoverflow.com/questions/12688717/round-up-from-5
8		#' * `iec`: the underlying rounding method is `round`
9		#'
10		#' @param na_str_dflt Character to represent NA value
11		#' @param replace_na_dflt logical(1). Should an `na_string` of "NA" within
12		#' the formatters framework be overridden by `na_str_default`? Defaults to
13		#' `TRUE`, as a way to have a different default na string behavior from the
14		#' base `formatters` framework.
15		#' @return `format_xx_fct()` format function that can be used in rtables formatting calls
16		#' @export
17		#'
18		#' @family JJCS formats
19		#' @examples
20		#' jjcsformat_xx_SAS <- format_xx_fct(roundmethod = "sas")
21		#' jjcsformat_xx <- jjcsformat_xx_SAS
22		#' rcell(c(1.453), jjcsformat_xx("xx.xx"))
23		#' rcell(c(), jjcsformat_xx("xx.xx"))
24		#' rcell(c(1.453, 2.45638), jjcsformat_xx("xx.xx (xx.xxx)"))
25		#'
26		format_xx_fct <- function(roundmethod = c("sas", "iec"), na_str_dflt = "NE",
27		replace_na_dflt = TRUE) {
28	!	roundmethod <- match.arg(roundmethod)
29
30	!	if (roundmethod == "sas") {
31	!	roundfunc <- tidytlg::roundSAS
32		} else {
33	!	roundfunc <- round
34		}
35
36	!	fnct <- function(str, na_str = na_str_dflt) {
37	450x	if (grepl("xxx.", str, fixed = TRUE)) {
38	!	stop(
39	!	"Error: jjcs_format_xx: do not use xxx. in input str, replace by xx. instead."
40		)
41		}
42	450x	if (!grepl("xx", str, fixed = TRUE)) {
43	1x	stop("Error: jjcs_format_xx: input str must contain xx.")
44		}
45	449x	positions <- gregexpr(
46	449x	pattern = "xx\\.?x*",
47	449x	text = str,
48	449x	perl = TRUE
49		)
50	449x	x_positions <- regmatches(x = str, m = positions)[[1]]
51		### str is splitted into pieces as xx. xx xx.xxx
52		### xx is no rounding
53		### xx. rounding to integer
54		### xx.x rounding to 1 decimal, etc
55
56	449x	no_round <- function(x, na_str = na_str_dflt) {
57	23x	if (is.na(x)) {
58	!	return(na_str)
59		} else {
60	23x	return(x)
61		}
62		}
63
64	449x	roundings <- lapply(X = x_positions, function(x) {
65	609x	y <- strsplit(split = "\\.", x = x)[[1]]
66		### "xx.x" will result in c("xx","x")
67		### "xx." will result in "xx"
68		### "xx" will remain "xx"
69
70	609x	if (x == "xx") {
71	34x	rounding <- no_round
72		} else {
73	575x	rounding <- function(x, na_str = na_str_dflt) {
74	1172x	if (is.na(x)) {
75	25x	return(na_str)
76		} else {
77	1147x	format(
78	1147x	roundfunc(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)),
79	1147x	nsmall = ifelse(length(y) > 1, nchar(y[2]), 0)
80		)
81		}
82		}
83		}
84	609x	return(rounding)
85		})
86	449x	rtable_format <- function(x, output, na_str = na_str_dflt) {
87	876x	if (anyNA(na_str) \|\| (replace_na_dflt && any(na_str == "NA"))) {
88	290x	na_inds <- which(is.na(na_str) \| (replace_na_dflt & na_str == "NA"))
89	290x	na_str[na_inds] <- rep(na_str_dflt, length.out = length(na_str))[na_inds]
90		}
91	876x	if (length(x) == 0 \|\| isTRUE(all(x == ""))) {
92	!	return(NULL)
93	876x	} else if (!length(positions[[1]]) == length(x)) {
94	3x	stop(
95	3x	"Error: input str in call to jjcs_format_xx must contain same number of xx as the number of stats."
96		)
97		}
98
99	873x	values <- Map(y = x, fun = roundings, na_str = na_str, function(y, fun, na_str) fun(y, na_str = na_str))
100	873x	regmatches(x = str, m = positions)[[1]] <- values
101	873x	return(str)
102		}
103	449x	return(rtable_format)
104		}
105	!	return(fnct)
106		}
107
108
109		jjcsformat_xx_SAS <- format_xx_fct(roundmethod = "sas")
110		jjcsformat_xx_R <- format_xx_fct(roundmethod = "iec")
111
112
113		### if we ever decide to switch rounding method, we just have to update jjcsformat_xx here
114
115		#' @title Formatting of values
116		#' @name jjcsformat_xx
117		#' @description jjcs formatting function
118		#' @param str The formatting that is required specified as a text string, eg "xx.xx"
119		#' @param na_str character. Na string that will be passed from `formatters` into
120		#' our formatting functions.
121		#' @export
122		jjcsformat_xx <- jjcsformat_xx_SAS
123
124		#' @name count_fraction
125		#' @title Formatting count and fraction values
126		#'
127		#' @description
128		#'
129		#' Formats a count together with fraction (and/or denominator) with special
130		#' consideration when count is 0, or fraction is 1.
131		#' \cr See also: tern::format_count_fraction_fixed_dp()
132		#'
133		#' @inheritParams format_xx_fct
134		#' @param x `numeric`\cr with elements `num` and `fraction` or `num`, `denom` and `fraction`.
135		#' @param d numeric(1). Number of digits to round fraction to (default=1)
136		#' @param ... Additional arguments passed to other methods.
137		#' @return A string in the format `count / denom (ratio percent)`. If `count`
138		#' is 0, the format is `0`. If fraction is >0.99, the format is
139		#' `count / denom (>99.9 percent)`
140		#' @family JJCS formats
141		#' @rdname count_fraction
142		#' @export
143		#' @examples
144		#' jjcsformat_count_fraction(c(7, 0.7))
145		#' jjcsformat_count_fraction(c(70000, 0.9999999))
146		#' jjcsformat_count_fraction(c(70000, 1))
147		#'
148		jjcsformat_count_fraction <- function(
149		x,
150		d = 1,
151		roundmethod = c("sas", "iec"),
152		...
153		) {
154	25x	roundmethod <- match.arg(roundmethod)
155	25x	attr(x, "label") <- NULL
156	25x	if (any(is.na(x))) {
157	!	return("-")
158		}
159
160	25x	checkmate::assert_vector(x)
161	25x	checkmate::assert_integerish(x[1])
162	25x	assert_proportion_value(
163	25x	x[2],
164	25x	include_boundaries = TRUE
165		)
166
167	25x	fraction <- x[2]
168
169	!	if (isTRUE(all.equal(fraction, 1))) fraction <- 1
170
171	25x	if (roundmethod == "sas") {
172	24x	fmtpct <- format(tidytlg::roundSAS(fraction * 100, d), nsmall = d)
173		} else {
174	1x	fmtpct <- format(round(fraction * 100, d), nsmall = d)
175		}
176
177	25x	result <- if (x[1] == 0) {
178	!	"0"
179	25x	} else if (fraction == 1) {
180		## per conventions still report as 100.0%
181	!	paste0(x[1], " (100.0%)")
182	25x	} else if (fmtpct == format(0, nsmall = d)) {
183		# else if (100x[2] < 10*(-d)) {
184		### example pct = 0.09999 ### <0.1% (even if fmtpct == 0.1,
185		# but the actual value of pct <0.1)
186	!	paste0(x[1], " (<", 10**(-d), "%)")
187	25x	} else if (fmtpct == format(100, nsmall = d)) {
188		# else if (100x[2] > 100-10*(-d)) {
189		### example pct = 99.90001 ### >99.9% (even if fmtpct == 99.9,
190		# but the actual value of pct >99.9)
191	!	paste0(x[1], " (>", 100 - 10**(-d), "%)")
192		} else {
193	25x	paste0(x[1], " (", fmtpct, "%)")
194		}
195	25x	return(result)
196		}
197
198		#' @title Formatting count, denominator and fraction values
199		#'
200		#' @inheritParams count_fraction
201		#' @param ... Additional arguments passed to other methods.
202		#' @export
203		#' @rdname count_denom_fraction
204		#' @examples
205		#' jjcsformat_count_denom_fraction(c(7, 10, 0.7))
206		#' jjcsformat_count_denom_fraction(c(70000, 70001, 70000 / 70001))
207		#' jjcsformat_count_denom_fraction(c(235, 235, 235 / 235))
208		jjcsformat_count_denom_fraction <- function(
209		x,
210		d = 1,
211		roundmethod = c("sas", "iec"),
212		...
213		) {
214	313x	roundmethod <- match.arg(roundmethod)
215	313x	attr(x, "label") <- NULL
216	313x	if (any(is.na(x))) {
217	55x	return("-")
218		}
219	258x	checkmate::assert_vector(x)
220	258x	checkmate::assert_integerish(x[1])
221	258x	assert_proportion_value(
222	258x	x[3],
223	258x	include_boundaries = TRUE
224		)
225
226	258x	fraction <- x[3]
227	109x	if (x[2] == x[1]) fraction <- 1
228
229	258x	fmt_x12 <- paste0(x[1], "/", x[2])
230
231	258x	if (roundmethod == "sas") {
232	257x	fmtpct <- format(tidytlg::roundSAS(fraction * 100, d), nsmall = d)
233		} else {
234	1x	fmtpct <- format(round(fraction * 100, d), nsmall = d)
235		}
236
237	258x	result <- if (x[1] == 0) {
238		# "0"
239		# same as in general situation
240	8x	paste0(fmt_x12, " (", fmtpct, "%)")
241	258x	} else if (100 * fraction == 100) {
242	109x	paste0(fmt_x12, " (100.0%)")
243	258x	} else if (100 * fraction < 10**(-d)) {
244		### example pct = 0.09999 ### <0.1% (even if fmtpct == 0.1, but the actual value of pct <0.1)
245	1x	paste0(fmt_x12, " (<", 10**(-d), "%)")
246	258x	} else if (100 * fraction > 100 - 10**(-d)) {
247		### example pct = 99.90001 ### >99.9% (even if fmtpct == 99.9, but the actual value of pct >99.9)
248	1x	paste0(fmt_x12, " (>", 100 - 10**(-d), "%)")
249		} else {
250	139x	paste0(fmt_x12, " (", fmtpct, "%)")
251		}
252	258x	return(result)
253		}
254
255		#' @title Formatting fraction, count and denominator values
256		#'
257		#' @inheritParams count_fraction
258		#' @param ... Additional arguments passed to other methods.
259		#' @export
260		#' @rdname fraction_count_denom
261		#' @examples
262		#' jjcsformat_fraction_count_denom(c(7, 10, 0.7))
263		#' jjcsformat_fraction_count_denom(c(70000, 70001, 70000 / 70001))
264		#' jjcsformat_fraction_count_denom(c(235, 235, 235 / 235))
265		jjcsformat_fraction_count_denom <- function(
266		x,
267		d = 1,
268		roundmethod = c("sas", "iec"),
269		...
270		) {
271	2x	roundmethod <- match.arg(roundmethod)
272	2x	attr(x, "label") <- NULL
273	2x	if (any(is.na(x))) {
274	!	return("-")
275		}
276	2x	checkmate::assert_vector(x)
277	2x	checkmate::assert_integerish(x[1])
278	2x	assert_proportion_value(
279	2x	x[3],
280	2x	include_boundaries = TRUE
281		)
282
283	2x	fraction <- x[3]
284	!	if (x[2] == x[1]) fraction <- 1
285
286	2x	fmt_x12 <- paste0(x[1], "/", x[2])
287
288	2x	if (roundmethod == "sas") {
289	1x	fmtpct <- format(tidytlg::roundSAS(fraction * 100, d), nsmall = d)
290		} else {
291	1x	fmtpct <- format(round(fraction * 100, d), nsmall = d)
292		}
293
294	2x	result <- if (x[1] == 0) {
295		# "0"
296		# same as in general situation
297	!	paste0("(", fmt_x12, ")")
298	2x	} else if (100 * fraction == 100) {
299	!	paste0("100.0%", " (", fmt_x12, ")")
300	2x	} else if (100 * fraction < 10**(-d)) {
301		### example pct = 0.09999 ### <0.1% (even if fmtpct == 0.1, but the actual value of pct <0.1)
302	!	paste0("<", 10**(-d), "%", " (", fmt_x12, ")")
303	2x	} else if (100 * fraction > 100 - 10**(-d)) {
304		### example pct = 99.90001 ### >99.9% (even if fmtpct == 99.9, but the actual value of pct >99.9)
305	!	paste0(">", 100 - 10**(-d), "%", " (", fmt_x12, ")")
306		} else {
307	2x	paste0(fmtpct, "%", " (", fmt_x12, ")")
308		}
309	2x	return(result)
310		}
311
312		#' @title Function factory for p-value formatting
313		#'
314		#' @description A function factory to generate formatting functions for p-value
315		#' formatting that support rounding close to the significance level specified
316		#'
317		#' @param alpha `number`\cr the significance level to account for during rounding.
318		#' @return The p-value in the standard format. If `count` is 0, the format is `0`.
319		#' If it is smaller than 0.001, then `<0.001`, if it is larger than 0.999, then
320		#' `>0.999` is returned. Otherwise, 3 digits are used. In the special case that
321		#' rounding from below would make the string equal to the specified `alpha`,
322		#' then a higher number of digits is used to be able to still see the difference.
323		#' For example, 0.0048 is not rounded to 0.005 but stays at 0.0048 if `alpha = 0.005`
324		#' is set.
325		#'
326		#' @family JJCS formats
327		#' @export
328		#'
329		#' @examples
330		#' my_pval_format <- jjcsformat_pval_fct(0.005)
331		#' my_pval_format(0.2802359)
332		#' my_pval_format(0.0048)
333		#' my_pval_format(0.00499)
334		#' my_pval_format(0.004999999)
335		#' my_pval_format(0.0051)
336		#' my_pval_format(0.0009)
337		#' my_pval_format(0.9991)
338		#'
339		jjcsformat_pval_fct <- function(alpha = 0.05) {
340	26x	checkmate::assert_number(alpha, lower = 0, upper = 1)
341
342	26x	function(x, ...) {
343	114x	checkmate::assert_number(
344	114x	x,
345	114x	lower = 0,
346	114x	upper = 1 + .Machine$double.eps, # Be a bit tolerant here.
347	114x	na.ok = TRUE
348		)
349	114x	if (is.na(x)) {
350	!	"NE"
351	114x	} else if (x < 0.001) {
352	34x	"<0.001"
353	80x	} else if (x > 0.999) {
354	3x	">0.999"
355		} else {
356	77x	xx_format <- "xx.xxx"
357	77x	res <- jjcsformat_xx(xx_format)(x)
358	77x	while (as.numeric(res) == alpha && x < alpha) {
359		# Increase precision by 1 digit until the result
360		# is different from threshold alpha.
361	3x	xx_format <- paste0(xx_format, "x")
362	3x	res <- jjcsformat_xx(xx_format)(x)
363		}
364	77x	res
365		}
366		}
367		}
368
369		#' @title Function factory for range with censoring information formatting
370		#' @description A function factory to generate formatting functions for range formatting
371		#' that includes information about the censoring of survival times.
372		#'
373		#' @param str `string`\cr the format specifying the number of digits to be used,
374		#' for the range values, e.g. `"xx.xx"`.
375		#' @return A function that formats a numeric vector with 4 elements:
376		#' - minimum
377		#' - maximum
378		#' - censored minimum? (1 if censored, 0 if event)
379		#' - censored maximum? (1 if censored, 0 if event)
380		#' The range along with the censoring information is returned as a string
381		#' with the specified numeric format as `(min, max)`, and the `+` is appended
382		#' to `min` or `max` if these have been censored.
383		#'
384		#' @family JJCS formats
385		#' @export
386		#'
387		#' @examples
388		#' my_range_format <- jjcsformat_range_fct("xx.xx")
389		#' my_range_format(c(0.35235, 99.2342, 1, 0))
390		#' my_range_format(c(0.35235, 99.2342, 0, 1))
391		#' my_range_format(c(0.35235, 99.2342, 0, 0))
392		#' my_range_format(c(0.35235, 99.2342, 1, 1))
393		jjcsformat_range_fct <- function(str) {
394	1x	format_xx <- jjcsformat_xx(str)
395
396	1x	function(x, ...) {
397	4x	checkmate::assert_numeric(
398	4x	x,
399	4x	len = 4L,
400	4x	finite = TRUE,
401	4x	any.missing = FALSE
402		)
403	4x	checkmate::assert_true(all(x[c(3, 4)] %in% c(0, 1)))
404
405	4x	res <- vapply(x[c(1, 2)], format_xx, character(1))
406	2x	if (x[3] == 1) res[1] <- paste0(res[1], "+")
407	2x	if (x[4] == 1) res[2] <- paste0(res[2], "+")
408	4x	paste0("(", res[1], ", ", res[2], ")")
409		}
410		}

1		#' Split Function for Compliance Columns (TEFSCNCMP01 e.g.)
2		#'
3		#' Here we just split into 3 columns for expected, received and missing visits.
4		#'
5		#' @inheritParams proposal_argument_convention
6		#' @param ret (`list`)\cr result from previous split function steps.
7		#' @param spl (`split`)\cr split object.
8		#' @param fulldf (`data.frame`)\cr full data frame.
9		#' @param vals (`character`)\cr values to use for the split.
10		#' @param trim (`logical`)\cr whether to trim the values.
11		#'
12		#' @note This split function is used in the proportion table TEFSCNCMP01 and similar ones.
13		#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
14		#' post-processing function.
15		cmp_post_fun <- function(ret, spl, fulldf, .spl_context) {
16	1x	short_split_result(
17	1x	expected = "Expected, N",
18	1x	received = "Received, n (%)",
19	1x	missing = "Missing, n (%)",
20	1x	fulldf = fulldf
21		)
22		}
23		#' @rdname cmp_post_fun
24		#' @export
25		cmp_split_fun <- make_split_fun(post = list(cmp_post_fun))
26
27		#' @title Summary Analysis Function for Compliance Columns (TEFSCNCMP01 e.g.)
28		#' @description A simple statistics function which prepares the numbers with percentages
29		#' in the required format, for use in a split content row. The denominator here is
30		#' from the expected visits column.
31		#' @inherit proposal_argument_convention
32		#' @param variables (`list`)\cr with variable names of logical columns for
33		#' `expected`, `received` and `missing` visits.
34		#' @param formats (`list`)\cr with the `count_percent` format to use for the received
35		#' and missing visits columns.
36		#' @return The [rtables::in_rows()] result with the counts and proportion statistics.
37		#' @seealso [cmp_post_fun()] for the corresponding split function.
38		#' @export
39		cmp_cfun <- function(df, labelstr, .spl_context, variables, formats) {
40	3x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
41	3x	this_afun_col <- this_col_split[2]
42
43	3x	exp <- df[[variables$expected]]
44	3x	checkmate::assert_logical(exp)
45	3x	n_exp <- sum(exp)
46	3x	rec <- df[[variables$received]]
47	3x	mis <- df[[variables$missing]]
48
49	3x	if (this_afun_col == "expected") {
50	1x	in_rows(n_exp, .labels = labelstr, .formats = "xx.")
51	2x	} else if (this_afun_col == "received") {
52	1x	checkmate::assert_logical(rec)
53	1x	checkmate::assert_true(all(exp[rec]))
54
55		# Check if count_percent format is available
56	1x	if (!is.null(formats) && !("count_percent" %in% names(formats))) {
57	!	stop("'count_percent' format must be provided in the formats argument")
58		}
59
60	1x	in_rows(sum(rec) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
61	1x	} else if (this_afun_col == "missing") {
62	1x	checkmate::assert_logical(mis)
63	1x	checkmate::assert_true(all(exp[mis]))
64	1x	checkmate::assert_true(!any(rec[mis]))
65
66		# Check if count_percent format is available
67	1x	if (!is.null(formats) && !("count_percent" %in% names(formats))) {
68	!	stop("'count_percent' format must be provided in the formats argument")
69		}
70
71	1x	in_rows(sum(mis) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
72		}
73		}

1
2		## contribute to formatters
3		#' @name inches_to_spaces
4		#' @title Conversion of inches to spaces
5		#' @param ins numeric. Vector of widths in inches
6		#' @param fontspec font_spec. The font specification to use
7		#' @param raw logical(1). Should the answer be returned unrounded
8		#' (`TRUE`), or rounded to the nearest reasonable value (`FALSE`,
9		#' the default)
10		#' @param tol numeric(1). The numeric tolerance, values
11		#' between an integer `n`, and `n+tol` will be returned
12		#' as `n`, rather than `n+1`, if `raw == FALSE`. Ignored
13		#' when `raw` is `TRUE`.
14		#' @export
15		inches_to_spaces <- function(ins, fontspec, raw = FALSE, tol = sqrt(.Machine$double.eps)) {
16	29x	newdev <- open_font_dev(fontspec)
17	29x	if (newdev) {
18	!	on.exit(close_font_dev())
19		}
20	29x	spcw <- grid::convertWidth(grid::unit(1, "strwidth", " "), "inches", valueOnly = TRUE)
21	29x	ans <- ins / spcw
22	29x	if (!raw) {
23	29x	win_tol <- ans - floor(ans) < tol
24	29x	ans[win_tol] <- floor(ans)
25	29x	ans[!win_tol] <- ceiling(ans)
26		}
27	29x	ans
28		}
29
30		#' @importFrom formatters wrap_string_ttype
31		ttype_wrap_vec <- function(vec, fontspec, width, wordbreak_ok = TRUE, ...) {
32	!	lapply(
33	!	vec,
34	!	wrap_string_ttype,
35	!	width_spc = width,
36	!	fontspec = fontspec,
37	!	wordbreak_ok = wordbreak_ok,
38		...
39		)
40		}
41
42		#' @name check_wrap_nobreak
43		#' @title Check Word Wrapping
44		#' @description Check a set of column widths for word-breaking wrap behavior
45		#' @param tt TableTree
46		#' @param colwidths numeric. Column widths (in numbers of spaces under `fontspec`)
47		#' @param fontspec font_spec.
48		#'
49		#' @return `TRUE` if the wrap is able to be done without breaking words,
50		#' `FALSE` if wordbreaking is required to apply `colwidths`
51		#' @rdname check_wrap_nobreak
52		#' @export
53		check_wrap_nobreak <- function(tt, colwidths, fontspec) {
54	!	newdev <- open_font_dev(fontspec)
55	!	if (newdev) {
56	!	on.exit(close_font_dev())
57		}
58	!	mpf <- matrix_form(tt, fontspec = fontspec)
59	!	strs <- mf_strings(mpf)
60	!	colok <- vapply(
61	!	seq_len(ncol(strs)),
62	!	function(i) {
63	!	res <- tryCatch(
64	!	ttype_wrap_vec(strs[, i, drop = TRUE], colwidths[i], fontspec = fontspec, wordbreak_ok = FALSE),
65	!	error = function(e) e
66		)
67	!	!methods::is(res, "error")
68		},
69	!	TRUE
70		)
71	!	all(colok)
72		}
73
74		#' Colwidths for all columns to be forced on one page
75		#'
76		#' @param tt TableTree object to calculate column widths for
77		#' @param fontspec Font specification object
78		#' @param col_gap Column gap in spaces
79		#' @param rowlabel_width Width of row labels in spaces
80		#' @param print_width_ins Print width in inches
81		#' @param landscape Whether the output is in landscape orientation
82		#' @param lastcol_gap Whether to include a gap after the last column
83		smart_colwidths_1page <- function(
84		tt,
85		fontspec,
86		col_gap = 6L,
87		rowlabel_width = inches_to_spaces(2, fontspec),
88		print_width_ins = ifelse(landscape, 11, 8.5) - 2.12,
89		landscape = FALSE,
90		lastcol_gap = TRUE
91		) {
92	!	total_cpp <- floor(inches_to_spaces(print_width_ins, fontspec = fontspec, raw = TRUE))
93
94	!	nc <- ncol(tt)
95	!	remain <- total_cpp - rowlabel_width - col_gap * (nc - !lastcol_gap)
96
97	!	c(rowlabel_width - col_gap, spread_integer(remain, nc))
98		}
99
100		spaces_to_inches <- function(spcs, fontspec) {
101	!	nchar_ttype(" ", fontspec, raw = TRUE) * spcs
102		}
103
104		no_cellwrap_colwidths <- function(tt, fontspec, col_gap = 4L, label_width_ins = 2) {
105	4x	if (is.null(col_gap)) {
106	!	col_gap <- 4L
107		}
108	4x	mpf <- matrix_form(tt, TRUE, FALSE, fontspec = fontspec, col_gap = col_gap)
109	4x	strmat <- mf_strings(mpf)
110	4x	label_width_max <- inches_to_spaces(label_width_ins, fontspec)
111
112	4x	nchar_mat <- nchar_ttype(strmat[-seq_len(mf_nlheader(mpf)), , drop = FALSE],
113	4x	fontspec = fontspec)
114
115	4x	label_width <- min(label_width_max,
116	4x	max(nchar_mat[, 1, drop = TRUE]))
117	4x	col_maxes <- apply(nchar_mat[, -1, drop = FALSE], 2, max)
118	4x	c(label_width, col_maxes + col_gap)
119		}
120
121		pack_into_lines2 <- function(strs, wrdwidths = nchar_ttype(strs), colwidth, fontspec) {
122	3782x	if (length(wrdwidths) == 0 \|\| (length(wrdwidths) == 1 && wrdwidths <= colwidth)) {
123	1156x	return(1)
124		}
125	2626x	newdev <- open_font_dev(fontspec)
126	2626x	if (newdev) {
127	!	on.exit(close_font_dev())
128		}
129
130	2626x	csums <- cumsum(wrdwidths + c(0, rep(1, length(wrdwidths) - 1)))
131	2626x	oneline_wdth <- sum(wrdwidths) + length(wrdwidths) - 1
132	2626x	if (colwidth >= ceiling(oneline_wdth)) {
133	1809x	return(1)
134		}
135	817x	lines <- 0
136	817x	wrdsused <- 0
137	817x	widthused <- 0
138	817x	index_seq <- seq_along(wrdwidths)
139	817x	totwrds <- length(wrdwidths)
140	817x	adj <- 0
141		## finite precision arithmetic is a dreamscape of infinite wonder
142	817x	tol <- sqrt(.Machine$double.eps)
143	817x	while (wrdsused < length(wrdwidths)) {
144	1944x	csums_i <- csums - widthused
145
146	1944x	fit <- which(index_seq > wrdsused & csums_i <= colwidth + tol)
147	1944x	widthused <- sum(widthused, wrdwidths[fit], length(fit))
148	1944x	wrdsused <- wrdsused + length(fit)
149	1944x	lines <- lines + 1
150		}
151	817x	lines
152		}
153
154		recursive_add_poss <- function(
155		wlst,
156		cur_lst,
157		ubnd_width,
158		lbnd_width,
159		ubnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = ubnd_width)$lines,
160		lbnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = lbnd_width)$lines,
161		fontspec
162		) {
163	109x	if (ubnd_width <= lbnd_width + 1 + sqrt(.Machine$double.eps)) {
164	27x	return(cur_lst)
165		}
166	82x	curw <- floor((ubnd_width + lbnd_width) / 2)
167	82x	curlnsdf <- calc_total_lns(wlst, fontspec = fontspec, colwidth = curw)
168	82x	to_add <- list(curlnsdf)
169
170	82x	if (curlnsdf$lines != lbnd_lines) {
171	50x	to_add <- c(
172	50x	to_add,
173	50x	recursive_add_poss(
174	50x	wlst = wlst,
175	50x	fontspec = fontspec,
176	50x	ubnd_width = curw,
177	50x	ubnd_lines = curlnsdf$lines,
178	50x	lbnd_width = lbnd_width,
179	50x	lbnd_lines = lbnd_lines,
180	50x	cur_lst = list()
181		)
182		)
183		}
184	82x	if (curlnsdf$lines != ubnd_lines) {
185	49x	to_add <- c(
186	49x	to_add,
187	49x	recursive_add_poss(
188	49x	wlst = wlst,
189	49x	fontspec = fontspec,
190	49x	ubnd_width = ubnd_width,
191	49x	ubnd_lines = ubnd_lines,
192	49x	lbnd_width = curw,
193	49x	lbnd_lines = curlnsdf$lines,
194	49x	cur_lst = list()
195		)
196		)
197		}
198
199	82x	c(cur_lst, to_add)
200		}
201
202		calc_total_lns <- function(wlst, colwidth, fontspec, lns_per_pg = 50) {
203	122x	lns <- vapply(
204	122x	seq_along(wlst),
205	122x	function(i) {
206	3782x	pack_into_lines2(wrdwidths = wlst[[i]], colwidth = colwidth, fontspec = fontspec)
207		},
208	122x	1
209		)
210	122x	nonblnks <- !vapply(wlst, function(x) length(x) == 0, TRUE)
211	122x	celllns <- lns[-1]
212	122x	cllsum <- sum(celllns)
213	122x	hdr <- lns[1]
214	122x	data.frame(
215	122x	colwidth = colwidth,
216	122x	lines = cllsum + ceiling(cllsum / lns_per_pg) * hdr,
217	122x	cell_lines = cllsum,
218	122x	lbl_lines = hdr,
219	122x	min_cell_lines = min(1, celllns[nonblnks], na.rm = TRUE),
220	122x	max_cell_lines = max(celllns)
221		)
222		}
223
224
225		calc_poss_lines <- function(wlst, lbound, avail_spc, fontspec) {
226	10x	minposs <- calc_total_lns(wlst, lbound + avail_spc, fontspec)
227	10x	maxposs <- calc_total_lns(wlst, lbound, fontspec)
228
229	10x	retlst <- list(minposs, maxposs)
230
231	10x	retlst <- recursive_add_poss(
232	10x	wlst = wlst,
233	10x	ubnd_width = lbound + avail_spc,
234	10x	lbnd_width = lbound,
235	10x	cur_lst = retlst,
236	10x	fontspec = fontspec
237		)
238	10x	do.call(rbind, retlst)
239		}
240
241
242		make_poss_wdf <- function(
243		mpf,
244		incl_header = FALSE,
245		col_gap = 3,
246		pg_width_ins = 8.88,
247		fontspec = font_spec("Times", 9, 1.2)
248		) {
249	1x	newdev <- open_font_dev(fontspec)
250	1x	if (newdev) {
251	!	on.exit(close_font_dev())
252		}
253	1x	if (!methods::is(mpf, "MatrixPrintForm")) {
254	1x	mpf <- matrix_form(mpf, fontspec = fontspec, col_gap = col_gap)
255		}
256	1x	strs <- mf_strings(mpf)
257	1x	if (!incl_header) {
258	!	strs <- strs[-seq_len(mf_nlheader(mpf)), ]
259		}
260	1x	nc <- ncol(strs)
261	1x	nr <- nrow(strs)
262		## strip out markup so we are not over countin (by as much)
263	1x	strs <- matrix(gsub("~[{[][[:alpha:]]+ ([^]}]+)[]}]", "\\1", strs), ncol = nc, nrow = nr)
264
265	1x	possrows <- lapply(seq_len(ncol(strs)), function(ii) {
266	10x	res <- one_col_strs(strs[, ii, drop = TRUE], fontspec = fontspec, col_gap = col_gap)
267	10x	res$col_num <- ii
268	10x	res
269		})
270
271	1x	possdf <- do.call(rbind, possrows)
272	1x	o <- order(possdf$col_num, possdf$colwidth)
273	1x	possdf <- possdf[o, ]
274	1x	possdf
275		}
276
277		#'
278		#' @param mpf (`listing_df` or `MatrixPrintForm` derived thereof)\cr The listing
279		#' calculate column widths for.
280		#' @param incl_header (`logical(1)`)\cr Should the constraint to not break up
281		#' individual words be extended to words in the column labels? Defaults to `TRUE`
282		#' @param col_gap (`numeric(1)`)\cr Amount of extra space (in spaces) to
283		#' assume between columns. Defaults to `0.5`
284		#' @param pg_width_ins (`numeric(1)`)\cr Number of inches in width for
285		#' the portion of the page the listing will be printed to. Defaults to `8.88`
286		#' which corresponds to landscape orientation on a standard page after margins.
287		#' @param fontspec (`font_spec`)\cr Defaults to Times New Roman 8pt font with 1.2 line
288		#' height.
289		#' @param verbose (`logical(1)`)\cr Should additional information messages be
290		#' displayed during the calculation of the column widths? Defaults to `FALSE`.
291		#' @returns A vector of column widths suitable to use in `tt_to_tlgrtf` and
292		#' other exporters.
293		#' @rdname def_colwidths
294		#' @export
295		listing_column_widths <- function(
296		mpf,
297		incl_header = TRUE,
298		col_gap = 0.5,
299		pg_width_ins = 8.88,
300		fontspec = font_spec("Times", 8, 1.2),
301		verbose = FALSE
302		) {
303	1x	newdev <- open_font_dev(fontspec)
304	1x	if (newdev) {
305	!	on.exit(close_font_dev())
306		}
307	1x	possdf <- make_poss_wdf(
308	1x	mpf = mpf,
309	1x	incl_header = incl_header,
310	1x	col_gap = col_gap,
311	1x	fontspec = fontspec,
312	1x	pg_width_ins = pg_width_ins
313		)
314	1x	optimal <- optimal_widths(
315	1x	possdf = possdf,
316	1x	tot_spaces = inches_to_spaces(pg_width_ins, fontspec = fontspec),
317	1x	verbose = verbose
318		)
319	1x	optimal$colwidth
320		}
321
322		find_free_colspc <- function(curposs, fullposs, thresh = 0.99, skip = integer(), verbose = FALSE) {
323	!	orig_curposs <- curposs
324	!	maxlns_ind <- which.max(curposs$cell_lines)
325	!	longestcol <- curposs$col_num[maxlns_ind]
326	!	maxlns <- curposs$cell_lines[maxlns_ind]
327	!	adjrow_inds <- setdiff(which(curposs$cell_lines < thresh * maxlns), skip)
328	!	for (arowi in adjrow_inds) {
329	!	col <- curposs$col_num[arowi]
330	!	colwidthii <- curposs$colwidth[arowi]
331	!	fp_ind <- with(fullposs, min(which(col_num == col & cell_lines <= maxlns & colwidth < colwidthii)))
332	!	if (is.finite(fp_ind)) {
333	!	if (verbose) {
334	!	oldwdth <- curposs$colwidth[arowi]
335	!	newwdth <- fullposs$colwidth[fp_ind]
336	!	msg <- sprintf("adjusting column %d width from %d to %d", col, oldwdth, newwdth)
337	!	message(msg)
338		}
339	!	curposs[arowi, ] <- fullposs[fp_ind, ]
340		}
341		}
342	!	curposs
343		}
344
345		constrict_lbl_lns <- function(curdf, possdf, avail_spc, verbose = TRUE) {
346	1x	old_lbl_lns <- max(curdf$lbl_lines)
347	1x	cols_to_pack <- which(curdf$lbl_lns == old_lbl_lns)
348	1x	olddf <- curdf
349	1x	success <- TRUE
350	1x	for (ii in cols_to_pack) {
351	!	colii <- curdf$col_num[ii]
352	!	cwidthii <- curdf$colwidth[ii]
353	!	possdfii <- possdf[possdf$col_num == colii & possdf$lbl_lines < old_lbl_lns, ]
354	!	if (nrow(possdfii) == 0) {
355	!	success <- FALSE
356	!	break
357		}
358	!	newrow <- possdfii[ii, ]
359	!	if (newrow$colwidth - cwidthii > avail_spc) {
360	!	success <- FALSE
361	!	break
362		}
363		## assuming sorted
364	!	curdf[ii, ] <- newrow
365	!	avail_spc <- avail_spc + cwidthii - newrow$colwidth
366		}
367
368	1x	if (verbose) {
369	!	if (success) {
370	!	msg <- paste(
371	!	"overall number of label rows successfully reduced. Cols affected: ",
372	!	paste(curdf$col_num[cols_to_pack], collapse = ", ")
373		)
374		} else {
375	!	msg <- paste("Unable to reduce label rows required.")
376		}
377		}
378
379	1x	if (!success) {
380	!	curdf <- olddf
381		}
382	1x	curdf
383		}
384
385		optimal_widths <- function(possdf, tot_spaces = 320, max_lbl_lines = 3, verbose = FALSE) {
386	1x	odf <- order(possdf$col_num, possdf$colwidth)
387	1x	possdf <- possdf[odf, ]
388	1x	badlbl <- which(possdf$lbl_lines > max_lbl_lines)
389	1x	if (length(badlbl > 0)) {
390	1x	if (verbose) {
391	!	message("Excluding ", length(badlbl), " column widths for labels taking over ", max_lbl_lines, " lines.")
392		}
393	1x	possdf <- possdf[-badlbl, ]
394	1x	possdf <- possdf[possdf$lbl_lines <= max_lbl_lines, , drop = FALSE]
395		}
396	1x	full_possdf <- possdf
397		## already ordered by colnum then width so this the first of each colwidth is the min width for that col
398	1x	dups <- duplicated(possdf$col_num)
399	1x	curdf <- possdf[!dups, ]
400	1x	possdf <- possdf[dups, ] ## without rows for ones in curdf
401	1x	spcleft <- tot_spaces - sum(curdf$colwidth)
402	1x	if (verbose) {
403	!	message(
404	!	"Optimizng Column Widths\n",
405	!	"Initial lines required: ",
406	!	max(curdf$lines),
407	!	"\n",
408	!	"Available adjustment: ",
409	!	spcleft,
410	!	" spaces\n"
411		)
412		}
413	1x	done <- FALSE
414	1x	while (!done) {
415	1x	oldwdths <- curdf$colwidth
416	1x	curdf <- constrict_lbl_lns(curdf, possdf, verbose = verbose)
417	1x	if (all.equal(curdf$colwidth, oldwdths)) {
418	1x	done <- TRUE
419		}
420		}
421	1x	change <- TRUE
422	1x	while (spcleft > 0 && change && nrow(possdf) > 0) {
423	6x	change <- FALSE
424	6x	ii <- which.max(curdf$cell_lines)
425	6x	spcleft <- tot_spaces - sum(curdf$colwidth)
426	6x	colii <- curdf$col_num[ii]
427	6x	bef_lns <- curdf$cell_lines[ii]
428	6x	bef_width <- curdf$colwidth[ii]
429	6x	nextlns <- max(curdf$cell_lines[-ii])
430	6x	cand_row_cond <- possdf$col_num == colii & possdf$cell_lines < bef_lns & possdf$colwidth - bef_width <= spcleft
431	6x	canddf <- possdf[cand_row_cond, , drop = FALSE]
432	6x	if (nrow(canddf) > 0) {
433	5x	more_than_next <- canddf$cell_lines >= nextlns
434	5x	if (any(more_than_next)) {
435	2x	candrow <- canddf[max(which(more_than_next)), ]
436		} else {
437	3x	candrow <- canddf[nrow(canddf), ]
438		}
439
440	5x	if (verbose) {
441	!	message(
442	!	"COL ",
443	!	colii,
444	!	" width: ",
445	!	bef_width,
446		"->",
447	!	candrow$colwidth,
448	!	" lines req: ",
449	!	bef_lns,
450		"->",
451	!	candrow$cell_lines
452		)
453		}
454	5x	change <- TRUE
455	5x	curdf[ii, ] <- candrow
456		}
457		}
458	1x	curdf
459		}
460
461
462		one_col_strs <- function(strcol, col_gap = 2, fontspec) {
463	10x	strspls <- strsplit(strcol, split = "(-\| (?=[^/]))", perl = TRUE)
464	10x	strspl_widths <- lapply(strspls, nchar_ttype, fontspec = fontspec, raw = TRUE)
465	10x	lbound_raw <- max(unlist(strspl_widths))
466	10x	lbound <- ceiling(lbound_raw + 2 * col_gap)
467	10x	ret <- calc_poss_lines(strspl_widths, lbound, 50, fontspec = fontspec)
468	10x	ret
469		}
470
471		## we have permission from the formatters maintainer to use this
472		## unexported function
473		j_mf_col_widths <- utils::getFromNamespace("mf_col_widths", "formatters")
474
475		#' @name def_colwidths
476		#'
477		#' @title Define Column Widths
478		#'
479		#' @description
480		#' function for aiding more personalized column widths in case default is not desired.
481		#'
482		#' @param tt input Tabletree
483		#' @param fontspec Font specification
484		#' @param label_width_ins Label Width in Inches.
485		#' @param col_gap Column gap.
486		#' @param type Type of the table tree, used to determine column width calculation method.
487		#' @examples # colwidths <- def_colwidths(result, font_spec('Times', 9L, 1.2), col_gap = 7L, label_width_ins = 2)
488		#' @export
489		#'
490		def_colwidths <- function(tt, fontspec, label_width_ins, col_gap, type = tlg_type(tt)) {
491	5x	if (type == "Figure") {
492	!	ret <- NULL
493	5x	} else if (type == "Table") {
494		if (
495	4x	is.list(tt) &&
496	4x	!methods::is(tt, "MatrixPrintForm") &&
497	4x	!is.null(j_mf_col_widths(tt[[1]]))
498		) {
499	!	ret <- j_mf_col_widths(tt[[1]])
500		} else {
501	4x	ret <- no_cellwrap_colwidths(tt, fontspec, col_gap = col_gap, label_width_ins = label_width_ins)
502		}
503		} else {
504	1x	ret <- listing_column_widths(tt, fontspec = fontspec, col_gap = col_gap)
505		}
506	5x	ret
507		}

1		make_dps_regex <- function(keyword, type = c("[", "{")) {
2	528x	mustart <- match.arg(type)
3	528x	muend <- ifelse(mustart == "[", "]", "}")
4
5	528x	paste0("[~][", mustart, "]", keyword, " ([^", muend, "]+)[", muend, "]")
6		}
7
8		handle_one_markup <- function(strs, keyword, rtfstart, rtfend) {
9	264x	start <- ifelse(nzchar(rtfstart), paste0("\\", rtfstart, " "), "")
10	264x	end <- ifelse(nzchar(rtfstart), paste0("\\", rtfend, " "), "")
11	264x	out <- gsub(make_dps_regex(keyword), paste0(start, "\\1", end), strs)
12	264x	out <- gsub(make_dps_regex(keyword, "{"), paste0(start, "\\1", end), out)
13	264x	out
14		}
15
16
17		dps_markup_df <- tibble::tribble(
18		~keyword,
19		~rtfstart,
20		~rtfend,
21		"super",
22		"\\super",
23		"\\nosupersub",
24		"sub",
25		"\\sub",
26		"\\nosupersub",
27		"optional",
28		"",
29		""
30		)
31
32
33		#' Default String Mapping for Special Characters
34		#'
35		#' A tibble that maps special characters to their UTF-8 equivalents for use in RTF output.
36		#' Currently it maps ">=" and "<=" to the Unicode characters.
37		#'
38		#' @return A tibble with columns 'pattern' and 'value', where 'pattern' contains
39		#' the string to be replaced and 'value' contains the replacement.
40		#'
41		#' @export
42		#' @keywords internal
43		default_str_map <- tibble::tribble(
44		~pattern,
45		~value,
46		">=",
47		intToUtf8(strtoi(2265, base = 16)),
48		"<=",
49		intToUtf8(strtoi(2264, base = 16))
50		)
51
52		convert_dps_markup <- function(strs, markup_df = dps_markup_df) {
53	88x	for (i in seq_len(nrow(markup_df))) {
54	264x	strs <- handle_one_markup(strs, markup_df$keyword[i], markup_df$rtfstart[i], markup_df$rtfend[i])
55		}
56	88x	strs
57		}
58
59		strmodify <- function(strs, replacement_str = default_str_map) {
60	88x	map_tbl <- replacement_str
61	88x	if (!is.null(map_tbl) && nrow(map_tbl) > 0) {
62	88x	for (i in seq_len(nrow(map_tbl))) {
63	176x	pattern <- map_tbl$pattern[[i]]
64	176x	value <- map_tbl$value[i]
65	176x	strs <- gsub(pattern, value, strs, fixed = TRUE)
66		}
67		}
68	88x	return(strs)
69		}
70
71		prep_strs_for_rtf <- function(strs, string_map = default_str_map, markup_df = dps_markup_df) {
72	88x	strs <- convert_dps_markup(strs, markup_df)
73	88x	strs <- strmodify(strs, string_map)
74	88x	return(strs)
75		}
76
77
78		#' Relabel Variables in a Dataset
79		#'
80		#' This function relabels variables in a dataset based on a provided list of labels.
81		#' It can either replace existing labels or only add labels to variables without them.
82		#'
83		#' @param x (`data.frame`)\cr dataset containing variables to be relabeled.
84		#' @param lbl_list (`list`)\cr named list of labels to apply to variables.
85		#' @param replace_existing (`logical`)\cr if TRUE, existing labels will be replaced;
86		#' if FALSE, only variables without labels will be updated.
87		#'
88		#' @return The dataset with updated variable labels.
89		#'
90		#' @export
91		#' @keywords internal
92		var_relabel_list <- function(x, lbl_list, replace_existing = TRUE) {
93	!	if (replace_existing) {
94	!	vars_to_relabel <- intersect(names(x), names(lbl_list))
95		} else {
96	!	get_variables_with_empty_labels <- function(x) {
97	!	labels <- var_labels(x)
98	!	mask <- lapply(labels, is.na) \|> unlist()
99	!	return(names(labels[mask]))
100		}
101
102	!	vars_without_labels <- get_variables_with_empty_labels(x)
103	!	vars_to_relabel <- intersect(vars_without_labels, names(lbl_list))
104		}
105	!	do.call(var_relabel, c(list(x = x), lbl_list[vars_to_relabel]))
106		}

1		#' @name safe_prune_table
2		#'
3		#' @title Safely Prune Table With Empty Table Message If Needed
4		#'
5		#' @inheritParams rtables::prune_table
6		#'
7		#' @param empty_msg character(1). The message to place in the table
8		#' if no rows were left after pruning
9		#'
10		#' @param spancols logical(1). Should `empty_msg` be spanned
11		#' across the table's columns (`TRUE`) or placed in the
12		#' rows row label (`FALSE`). Defaults to `FALSE` currently.
13		#'
14		#' @rdname safe_prune_table
15		#' @return `tt` pruned based on the arguments, or, if
16		#' pruning would remove all rows, a TableTree with the
17		#' same column structure, and one row containing the
18		#' empty message spanning all columns
19		#'
20		#' @export
21		#' @examples
22		#' # always prune
23		#' prfun <- function(tt) TRUE
24		#'
25		#' lyt <- basic_table() \|>
26		#' split_cols_by('ARM') \|>
27		#' split_cols_by('STRATA1') \|>
28		#' split_rows_by('SEX') \|>
29		#' analyze('AGE')
30		#' tbl <- build_table(lyt, ex_adsl)
31		#'
32		#' safe_prune_table(tbl, prfun)
33		safe_prune_table <- function(
34		tt,
35		prune_func = prune_empty_level,
36		stop_depth = NA,
37		empty_msg = " - No Data To Display - ",
38		spancols = FALSE
39		) {
40	6x	ret <- prune_table(tt = tt, prune_func = prune_func, stop_depth = stop_depth, depth = 0)
41	6x	if (is.null(ret)) {
42	3x	ret <- tt[integer(), , keep_titles = TRUE, keep_topleft = TRUE, keep_footers = TRUE]
43
44	3x	if (spancols) {
45		## this will eventually be the only option...
46	1x	ret <- sanitize_table_struct(ret, empty_msg = empty_msg)
47		} else {
48	2x	tree_children(ret) <- list(rrowl(empty_msg, rep(" ", ncol(tt))))
49		}
50		}
51	6x	ret
52		}
53
54		#' @name count_pruner
55		#'
56		#' @title Count Pruner
57		#'
58		#' @description
59		#' This is a pruning constructor function which identifies records to be pruned
60		#' based on the count (assumed to be the first statistic displayed when a compound
61		#' statistic (e.g., ## / ## (XX.X percent) is presented).
62		#'
63		#' @param count count threshold. Function will keep all records strictly greater
64		#' than this threshold.
65		#' @param cols column path (character or integer (column indices))
66		#' @param cat_include Category to be considered for pruning
67		#' @param cat_exclude logical Category to be excluded from pruning
68		#' @export
69		#'
70		#'
71		#' @examples
72		#'
73		#' ADSL <- data.frame(
74		#' USUBJID = c(
75		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
76		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
77		#' ),
78		#' TRT01P = factor(
79		#' c(
80		#' 'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
81		#' 'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
82		#' )
83		#' ),
84		#' FASFL = c('Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'Y'),
85		#' SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
86		#' PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
87		#' )
88		#'
89		#' lyt <- basic_table() \|>
90		#' split_cols_by('TRT01P') \|>
91		#' add_overall_col('Total') \|>
92		#' analyze('FASFL',
93		#' var_labels = 'Analysis set:',
94		#' afun = a_freq_j,
95		#' extra_args = list(label = 'Full', val = 'Y'),
96		#' show_labels = 'visible'
97		#' ) \|>
98		#' analyze('SAFFL',
99		#' var_labels = 'Analysis set:',
100		#' afun = a_freq_j,
101		#' extra_args = list(label = 'Safety', val = 'Y'),
102		#' show_labels = 'visible'
103		#' ) \|>
104		#' analyze('PKFL',
105		#' var_labels = 'Analysis set:',
106		#' afun = a_freq_j,
107		#' extra_args = list(label = 'PK', val = 'Y'),
108		#' show_labels = 'visible'
109		#' )
110		#'
111		#' result <- build_table(lyt, ADSL)
112		#'
113		#' result
114		#'
115		#' # use pruning function to prune where total column has >0 count,
116		#' # but exclude pruning safety set row
117		#' result <- prune_table(
118		#' result,
119		#' prune_func = count_pruner(cat_exclude = c('Safety'), cols = 'Total')
120		#' )
121		#'
122		#' result
123		#'
124		#' @rdname count_pruner
125		#' @returns function that can be utilized as pruning function in prune_table
126		#'
127		count_pruner <- function(count = 0, cat_include = NULL, cat_exclude = NULL, cols = c("TRT01A")) {
128	6x	function(tt) {
129		# Do not ever prune the following rows. a row that should be kept in the table will get the value of FALSE
130
131	6x	if (
132	1089x	!methods::is(tt, "TableRow") \|\|
133	1089x	methods::is(tt, "LabelRow") \|\|
134	1089x	obj_label(tt) == " " \|\|
135	1089x	(!is.null(cat_include) &&
136	1089x	!obj_label(tt) %in% cat_include) \|\|
137	1089x	(!is.null(cat_exclude) && obj_label(tt) %in% cat_exclude)
138		) {
139	655x	return(FALSE)
140		}
141
142		# Check the remaining rows to see if any meet the specified threshold.
143
144	434x	if (!is.null(cols)) {
145	434x	tt <- subset_cols(tt, cols)
146		}
147
148		# init return value to FALSE (not remove row)
149	434x	remove <- FALSE
150
151	434x	colpaths <- col_paths(tt)
152		# identify non relative risk columns as in rrisk columns first element is not a count, but diff percentage with
153		# small total columns and count > 0 (eg count = 1, n per group = 10), you can run into count1 = 1, countpbo =
154		# 0, diffpct = 10, this row should not be considered though
155	434x	cp_nonrelrisk <- vapply(
156	434x	colpaths,
157	434x	function(pth) {
158	1308x	!any(grepl("rrisk", tolower(pth)))
159		},
160	434x	FUN.VALUE = TRUE
161		)
162
163		## only continue if at least one non relative risk column selected
164	434x	if (any(cp_nonrelrisk)) {
165		# get cell_values of non rel risk columns
166	434x	cell_vals <- cell_values(tt)[cp_nonrelrisk]
167
168	434x	len_cell_vals <- lapply(cell_vals, function(x) {
169	1302x	length(x)
170		})
171
172	434x	if (any(len_cell_vals == 0)) {
173	!	stop("column cell values has not appropriate structure (a column with NULL value).")
174		}
175
176		# get count (first element)
177	434x	counts <- unlist(
178	434x	lapply(cell_vals, function(x) {
179	1302x	x[[1]]
180		}),
181	434x	use.names = FALSE
182		)
183
184		# check that we do have counts only
185	434x	checkmate::assert_integerish(counts)
186
187	434x	keep <- counts > count
188		# the row should be kept if at least one column has count above threshold
189	434x	keep <- any(keep)
190
191		# pruning function should return TRUE if row has to be removed, ie opposite of keep
192	434x	remove <- !keep
193		}
194
195	434x	return(remove)
196		}
197		}
198
199
200		#' @name bspt_pruner
201		#'
202		#' @title Pruning Function for pruning based on a fraction and/or a difference from the control arm
203		#'
204		#' @description
205		#' This is a pruning constructor function which identifies records to be pruned
206		#' based on the the fraction from the percentages. In addition to just looking at a fraction within an arm
207		#' this function also allows further flexibility to also prune based on a comparison versus the control arm.
208		#' @param fraction fraction threshold. Function will keep all records strictly greater
209		#' than this threshold.
210		#' @param cols column path.
211		#' @param keeprowtext Row to be excluded from pruning.
212		#' @param reg_expr Apply keeprowtext as a regular expression (grepl with fixed = TRUE)
213		#' @param control Control Group
214		#' @param diff_from_control Difference from control threshold.
215		#' @param only_more_often TRUE: Only consider when column pct is more often
216		#' than control. FALSE: Also select a row where column pct is less often than
217		#' control and abs(diff) above threshold
218		#'
219		#' @export
220		#'
221		#'
222		#' @examples
223		#' ADSL <- data.frame(
224		#' USUBJID = c(
225		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
226		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
227		#' ),
228		#' TRT01P = c(
229		#' 'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB',
230		#' 'Placebo', 'Placebo', 'Placebo', 'ARMA', 'ARMB'
231		#' ),
232		#' FASFL = c('Y', 'Y', 'Y', 'Y', 'N', 'Y', 'Y', 'Y', 'Y', 'Y'),
233		#' SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
234		#' PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
235		#' )
236		#'
237		#' ADSL <- ADSL \|>
238		#' dplyr::mutate(TRT01P = as.factor(TRT01P)) \|>
239		#' dplyr::mutate(SAFFL = factor(SAFFL, c("Y", "N"))) \|>
240		#' dplyr::mutate(PKFL = factor(PKFL, c("Y", "N")))
241		#'
242		#' lyt <- basic_table() \|>
243		#' split_cols_by('TRT01P') \|>
244		#' add_overall_col('Total') \|>
245		#'
246		#' split_rows_by(
247		#' "FASFL",
248		#' split_fun = drop_and_remove_levels("N"),
249		#' child_labels = "hidden"
250		#' ) \|>
251		#' analyze('FASFL',
252		#' var_labels = 'Analysis set:',
253		#' afun = a_freq_j,
254		#' show_labels = 'visible',
255		#' extra_args = list(label = 'Full', .stats = "count_unique_fraction")
256		#' ) \|>
257		#'
258		#' split_rows_by(
259		#' "SAFFL",
260		#' split_fun = remove_split_levels("N"),
261		#' child_labels = "hidden"
262		#' ) \|>
263		#' analyze('SAFFL',
264		#' var_labels = 'Analysis set:',
265		#' afun = a_freq_j,
266		#' show_labels = 'visible',
267		#' extra_args = list(label = 'Safety', .stats = "count_unique_fraction")
268		#' ) \|>
269		#'
270		#' split_rows_by(
271		#' "PKFL",
272		#' split_fun = remove_split_levels("N"),
273		#' child_labels = "hidden"
274		#' ) \|>
275		#' analyze('PKFL',
276		#' var_labels = 'Analysis set:',
277		#' afun = a_freq_j,
278		#' show_labels = 'visible',
279		#' extra_args = list(label = 'PK', .stats = "count_unique_fraction")
280		#' )
281		#'
282		#' result <- build_table(lyt, ADSL)
283		#'
284		#' result
285		#'
286		#' # use pruning function to prune rows where it doesn't meet 5% criteria
287		#' # in the total column but it will not
288		#' # prune the Safety row regardless
289		#' result <- prune_table(
290		#' result,
291		#' prune_func = bspt_pruner(
292		#' fraction = 0.05,
293		#' keeprowtext = 'Safety',
294		#' cols = c('Total')
295		#' )
296		#' )
297		#'
298		#' result
299		#' @rdname bspt_pruner
300		#' @returns function that can be utilized as pruning function in prune_table
301		#'
302		bspt_pruner <- function(
303		fraction = 0.05,
304		keeprowtext = "Analysis set: Safety",
305		reg_expr = FALSE,
306		control = NULL,
307		diff_from_control = NULL,
308		only_more_often = TRUE,
309		cols = c("TRT01A")
310		) {
311	12x	if (is.null(fraction) && is.null(diff_from_control)) {
312	1x	stop("At least one of fraction or diff_from_control must be non-NULL.")
313		}
314	11x	if (!is.null(diff_from_control) && is.null(control)) {
315	1x	stop("control must be specified when diff_from_control is not NULL.")
316		}
317
318	10x	function(tt) {
319		# Do not ever prune the following rows.
320	137x	if (!methods::is(tt, "TableRow") \|\| methods::is(tt, "LabelRow")) {
321	24x	return(FALSE)
322		}
323
324	10x	if (
325	113x	reg_expr &&
326	113x	any(sapply(keeprowtext, function(x) {
327	!	grepl(x, obj_label(tt), fixed = TRUE)
328		}))
329		) {
330	!	return(FALSE)
331		}
332	113x	if (!reg_expr && obj_label(tt) %in% keeprowtext) {
333	10x	return(FALSE)
334		}
335
336		# init return value to FALSE (not remove row)
337	103x	remove <- FALSE
338
339		# needed later for control column
340	103x	tt_all_cols <- tt
341
342	103x	if (!is.null(cols)) {
343	103x	tt <- subset_cols(tt, cols)
344		}
345
346	103x	colpaths <- col_paths(tt)
347		# identify non relative risk columns
348	103x	cp_nonrelrisk <- vapply(
349	103x	colpaths,
350	103x	function(pth) {
351	329x	!any(grepl("rrisk", tolower(pth)))
352		},
353	103x	FUN.VALUE = TRUE
354		)
355
356		## only continue if at least one non relative risk column selected
357	103x	if (any(cp_nonrelrisk)) {
358		# get rid of rel risk columns (if present)
359	103x	cell_vals <- cell_values(tt)[cp_nonrelrisk]
360
361	103x	len_cell_vals <- lapply(cell_vals, function(x) {
362	296x	length(x)
363		})
364
365	103x	if (any(len_cell_vals < 2)) {
366	!	stop("column cell values has not appropriate structure (less than 2 values in cell).")
367		}
368
369		# get count and percentage columns counts in first col pcts in second col
370	103x	counts <- unname(lst_slicer(cell_vals, 1, numeric(1)))
371	103x	pcts <- unname(lst_slicer(cell_vals, 2, numeric(1)))
372
373	103x	checkmate::check_integerish(counts)
374		# similarly check that pcts is indeed a percentage
375	103x	if (!all(dplyr::between(pcts, 0, 1))) {
376	!	stop("second value column cell is not a percentage.")
377		}
378
379	103x	if (!is.null(fraction)) {
380		# avoid problems with FALSE for 0.05 >= 0.05
381	103x	check_pcts <- pcts >= fraction \|
382	103x	vapply(
383	103x	pcts,
384	103x	function(x) {
385	296x	isTRUE(all.equal(x, fraction))
386		},
387	103x	TRUE
388		)
389		}
390
391	103x	if (!is.null(diff_from_control)) {
392		# get control group from all columns tt (in case the columns selected would not include the control
393		# group)
394	78x	colpaths0 <- col_paths(subset_cols(tt_all_cols, c(control)))
395	78x	cp0_nonrelrisk <- vapply(
396	78x	colpaths0,
397	78x	function(pth) {
398	83x	!any(grepl("rrisk", tolower(pth)))
399		},
400	78x	FUN.VALUE = TRUE
401		)
402	78x	colpaths0 <- colpaths0[cp0_nonrelrisk]
403
404	78x	if (length(colpaths0) != 1) {
405	1x	stop("control group spec does not result in single column.")
406		} else {
407	77x	colpaths0 <- colpaths0[[1]]
408		# get percent from control group
409	77x	pct0 <- cell_values(tt_all_cols, colpath = c(control))[[1]][2]
410
411	77x	if (!dplyr::between(pct0, 0, 1)) {
412	!	stop("second value of control column cell is not a percentage.")
413		}
414		}
415
416		# check if control group column was also present in main column selector
417	77x	colid0 <- which(sapply(colpaths, function(x) {
418	248x	all(x == colpaths0)
419		}))
420
421	77x	pctdiffs <- pcts - pct0
422
423		# exclude control column from this (would only be relevant if we want to check criteria on all columns
424		# rather than any column)
425	66x	if (!identical(colid0, integer(0))) pctdiffs <- pctdiffs[-colid0]
426
427		# if not only_more_often be equally strict on worse from control, better as control ie also select rows
428		# where column is less often than control pct = 0.07 pct0 = 0.10 (diff = -0.03 )
429	22x	if (!only_more_often) pctdiffs <- abs(pctdiffs)
430
431		# avoid problems with FALSE for 0.02 >= 0.02
432	77x	check_diffpcts <- pctdiffs >= diff_from_control \|
433	77x	vapply(
434	77x	pctdiffs,
435	77x	function(x) {
436	161x	isTRUE(all.equal(x, diff_from_control))
437		},
438	77x	TRUE
439		)
440		}
441
442		# final step to check if row should be kept in table
443	102x	if (!is.null(fraction) && is.null(diff_from_control)) {
444		# keep row in table if any column pct above threshold
445	25x	keep <- any(check_pcts)
446	77x	} else if ((!is.null(fraction) && !is.null(diff_from_control))) {
447		# if any column pct above threshold AND any diff pct above threshold note any is used in both
448		# expressions separately situation pct = 0.04 pct0 = 0.06 should be kept (fraction = 0.05, abs(diff
449		# control) = 0.02) this problem only arises in the non-default situation when only_more_often is FALSE
450		# (ie when column pct is less often than control) this would not be the case if we would any(check_pcts
451		# & check_diffpcts) as 0.04 is below fraction
452	77x	keep <- any(check_pcts) && any(check_diffpcts)
453	!	} else if ((is.null(fraction) && !is.null(diff_from_control))) {
454	!	keep <- any(check_diffpcts)
455		}
456
457		# pruning function should return TRUE if row has to be removed, ie opposite of keep
458	102x	remove <- !keep
459		}
460
461	102x	return(remove)
462		}
463		}
464
465		lst_slicer <- function(lst, ind, type) {
466	206x	vapply(lst, `[[`, i = ind, type)
467		}
468
469		#' @name remove_rows
470		#'
471		#' @title
472		#' Pruning function to remove specific rows of a table regardless of counts
473		#' @description
474		#' This function will remove all rows of a table based on the row text
475		#' provided by the user.
476		#' @param removerowtext define a text string for which any row with row text will be removed.
477		#' @param reg_expr Apply removerowtext as a regular expression (grepl with fixed = TRUE)
478		#' @export
479		#' @rdname remove_rows
480		#'
481		#'
482		#' @examples
483		#' ADSL <- data.frame(
484		#' USUBJID = c(
485		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
486		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
487		#' ),
488		#' TRT01P = c(
489		#' 'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB', 'Placebo',
490		#' 'Placebo', 'Placebo', 'ARMA', 'ARMB'
491		#' ),
492		#' Category = c(
493		#' 'Cat 1', 'Cat 2', 'Cat 1', 'Unknown', 'Cat 2',
494		#' 'Cat 1', 'Unknown', 'Cat 1', 'Cat 2', 'Cat 1'
495		#' ),
496		#' SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
497		#' PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
498		#' )
499		#'
500		#' ADSL <- ADSL \|>
501		#' dplyr::mutate(TRT01P = as.factor(TRT01P))
502		#'
503		#' lyt <- basic_table() \|>
504		#' split_cols_by("TRT01P") \|>
505		#'
506		#' analyze(
507		#' "Category",
508		#' afun = a_freq_j,
509		#' extra_args = list(.stats = "count_unique_fraction")
510		#' )
511		#'
512		#' result <- build_table(lyt, ADSL)
513		#'
514		#' result
515		#'
516		#' # use pruning function to prune rows where category is Unknown
517		#' result <- prune_table(result, prune_func = remove_rows(removerowtext = 'Unknown'))
518		#'
519		#' result
520		#' @aliases remove_rows
521		#' @returns function that can be utilized as pruning function in prune_table
522		#'
523		remove_rows <- function(removerowtext = NULL, reg_expr = FALSE) {
524	5x	function(tt) {
525	97x	if (!methods::is(tt, "TableRow") \|\| methods::is(tt, "LabelRow")) {
526	5x	return(FALSE)
527		}
528
529	92x	ret <- FALSE
530	92x	if (!is.null(removerowtext)) {
531	72x	if (!reg_expr) {
532	37x	ret <- obj_label(tt) %in% removerowtext
533		} else {
534	35x	ret <- any(sapply(removerowtext, function(x) {
535	52x	grepl(x, obj_label(tt), fixed = TRUE)
536		}))
537		}
538		}
539
540	92x	ret
541		}
542		}
543
544		#' @name keep_non_null_rows
545		#'
546		#' @title Pruning Function to accommodate removal of completely NULL rows within a table
547		#'
548		#' @description
549		#' Condition function on individual analysis rows. Flag as FALSE when all
550		#' columns are NULL, as then the row should not be kept. To be utilized as a
551		#' row_condition in function tern::keep_rows
552		#'
553		#' @param tr table tree object
554		#' @export
555		#'
556		#'
557		#' @examples
558		#'
559		#' library(dplyr)
560		#'
561		#' ADSL <- data.frame(
562		#' USUBJID = c(
563		#' 'XXXXX01', 'XXXXX02', 'XXXXX03', 'XXXXX04', 'XXXXX05',
564		#' 'XXXXX06', 'XXXXX07', 'XXXXX08', 'XXXXX09', 'XXXXX10'
565		#' ),
566		#' TRT01P = c(
567		#' 'ARMA', 'ARMB', 'ARMA', 'ARMB', 'ARMB', 'Placebo',
568		#' 'Placebo', 'Placebo', 'ARMA', 'ARMB'
569		#' ),
570		#' AGE = c(34, 56, 75, 81, 45, 75, 48, 19, 32, 31),
571		#' SAFFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N'),
572		#' PKFL = c('N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N', 'N')
573		#' )
574		#'
575		#' ADSL <- ADSL \|>
576		#' mutate(TRT01P = as.factor(TRT01P))
577		#'
578		#' create_blank_line <- function(x) {
579		#' list(
580		#' 'Mean' = rcell(mean(x), format = 'xx.x'),
581		#' ' ' = rcell(NULL),
582		#' 'Max' = rcell(max(x))
583		#' )
584		#' }
585		#'
586		#' lyt <- basic_table() \|>
587		#' split_cols_by('TRT01P') \|>
588		#' analyze('AGE', afun = create_blank_line)
589		#'
590		#' result <- build_table(lyt, ADSL)
591		#'
592		#' result
593		#' # use pruning function to prune rows where category is Unknown
594		#' result <- prune_table(result, prune_func = tern::keep_rows(keep_non_null_rows))
595		#'
596		#' result
597		#' @rdname keep_non_null_rows
598		#' @returns a function that can be utilized as a row_condition in the tern::keep_rows function
599		#'
600		keep_non_null_rows <- function(tr) {
601	42x	if (methods::is(tr, "DataRow")) {
602	41x	r_cellvalue_null <- unlist(lapply(cell_values(tr), is.null))
603	41x	check <- all(r_cellvalue_null)
604
605		### if check TRUE (all cell values NULL -- need to return FALSE as need to remove)
606	41x	ret <- !check
607		} else {
608	1x	ret <- TRUE
609		}
610	42x	ret
611		}